summaryrefslogtreecommitdiff
path: root/tests/examplefiles/example.xtm
diff options
context:
space:
mode:
Diffstat (limited to 'tests/examplefiles/example.xtm')
-rw-r--r--tests/examplefiles/example.xtm1101
1 files changed, 0 insertions, 1101 deletions
diff --git a/tests/examplefiles/example.xtm b/tests/examplefiles/example.xtm
deleted file mode 100644
index 927117da..00000000
--- a/tests/examplefiles/example.xtm
+++ /dev/null
@@ -1,1101 +0,0 @@
-;;; example.xtm -- Extempore code examples
-
-;; Author: Ben Swift, Andrew Sorensen
-;; Keywords: extempore
-
-;;; Commentary:
-
-
-
-;;; Code:
-
-;; bit twiddling
-
-(xtmtest '(bind-func test_bit_twiddle_1
- (lambda ()
- (bitwise-and 65535 255 15 1)))
-
- (test_bit_twiddle_1) 1)
-
-(xtmtest '(bind-func test_bit_twiddle_2
- (lambda ()
- (bitwise-not -1)))
-
- (test_bit_twiddle_2) 0)
-
-(xtmtest '(bind-func test_bit_twiddle_3
- (lambda ()
- (bitwise-not 0)))
-
- (test_bit_twiddle_3) -1)
-
-(xtmtest '(bind-func test_bit_twiddle_4
- (lambda ()
- (bitwise-shift-right 65535 8)
- (bitwise-shift-right 65535 4 4)))
-
- (test_bit_twiddle_4) 255)
-
-(xtmtest '(bind-func test_bit_twiddle_5
- (lambda ()
- (bitwise-shift-left (bitwise-shift-right 65535 8) 4 4)))
-
- (test_bit_twiddle_5) 65280)
-
-(xtmtest '(bind-func test_bit_twiddle_6
- (lambda ()
- (bitwise-and (bitwise-or (bitwise-eor 21844 65534) (bitwise-eor 43690 65534)) 1)))
-
- (test_bit_twiddle_6) 0)
-
-;; integer literals default to 64 bit integers
-(xtmtest '(bind-func int-literal-test
- (lambda (a)
- (* a 5)))
-
- (int-literal-test 6) 30)
-
-;; float literals default to doubles
-(xtmtest '(bind-func float-literal-test
- (lambda (a)
- (* a 5.0)))
-
- (float-literal-test 6.0) 30.0)
-
-;; you are free to recompile an existing closure
-(xtmtest '(bind-func int-literal-test
- (lambda (a)
- (/ a 5)))
-
- (int-literal-test 30))
-
-(xtmtest '(bind-func closure-test1
- (let ((power 0))
- (lambda (x)
- (set! power (+ power 1)) ;; set! for closure mutation as per scheme
- (* x power))))
-
- (closure-test1 2))
-
-(xtmtest '(bind-func closure-returns-closure-test
- (lambda ()
- (lambda (x)
- (* x 3))))
-
- (closure-returns-closure-test))
-
-(xtmtest '(bind-func incrementer-test1
- (lambda (i:i64)
- (lambda (incr)
- (set! i (+ i incr))
- i)))
-
- (incrementer-test1 0))
-
-(define myf (incrementer-test1 0))
-
-;; so we need to type f properly
-(xtmtest '(bind-func incrementer-test2
- (lambda (f:[i64,i64]* x)
- (f x)))
- (incrementer-test2 myf 1) 1)
-
-;; and we can call my-in-maker-wrapper
-;; to appy myf
-(xtmtest-result (incrementer-test2 myf 1) 2)
-(xtmtest-result (incrementer-test2 myf 1) 3)
-(xtmtest-result (incrementer-test2 myf 1) 4)
-
-;; of course the wrapper is only required if you
-;; need interaction with the scheme world.
-;; otherwise you just call my-inc-maker directly
-
-;; this avoids the wrapper completely
-(xtmtest '(bind-func incrementer-test3
- (let ((f (incrementer-test1 0)))
- (lambda ()
- (f 1))))
-
- (incrementer-test3) 1)
-
-(xtmtest-result (incrementer-test3) 2)
-(xtmtest-result (incrementer-test3) 3)
-
-;; hopefully you're getting the idea.
-;; note that once we've compiled something
-;; we can then use it any of our new
-;; function definitions.
-
-;; do a little 16bit test
-(xtmtest '(bind-func bitsize-sixteen
- (lambda (a:i16)
- (dtoi16 (* (i16tod a) 5.0))))
-
- (bitsize-sixteen 5) 25)
-
-;; while loop test
-
-(xtmtest '(bind-func test_while_loop_1
- (lambda ()
- (let ((count 0))
- (while (< count 5)
- (printf "count = %lld\n" count)
- (set! count (+ count 1)))
- count)))
-
- (test_while_loop_1) 5)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Closures can be recursive
-;;
-
-(xtmtest '(bind-func recursive-closure-test
- (lambda (a)
- (if (< a 1)
- (printf "done\n")
- (begin (printf "a: %lld\n" a)
- (recursive-closure-test (- a 1))))))
-
- (recursive-closure-test 3))
-
-;; check TAIL OPTIMIZATION
-;; if there is no tail call optimiation
-;; in place then this should blow the
-;; stack and crash the test
-
-;; CANNOT RUN THIS TEST ON WINDOWS (i.e. no salloc)!
-(if (not (equal? (sys:platform) "Windows"))
- (xtmtest '(bind-func tail_opt_test
- (lambda (n:i64)
- (let ((a:float* (salloc 8000)))
- (if (= n 0)
- (printf "tail opt test passed!\n")
- (tail_opt_test (- n 1))))))
-
- (tail_opt_test 200)))
-
-(println 'A 'segfault 'here 'incidates 'that 'tail-call-optimizations 'are 'not 'working!)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; some anon lambda tests
-;;
-
-(xtmtest '(bind-func infer_lambdas_test
- (lambda ()
- (let ((a 5)
- (b (lambda (x) (* x x)))
- (c (lambda (y) (* y y))))
- (c (b a)))))
-
- (infer_lambdas_test))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; a simple tuple example
-;;
-;; tuple types are represented as <type,type,type>*
-;;
-
-;; make and return a simple tuple
-(xtmtest '(bind-func tuple-test1
- (lambda ()
- (let ((t:<i64,double,i32>* (alloc)))
- t)))
-
- (tuple-test1))
-
-;; logview shows [<i64,double,i32>*]*
-;; i.e. a closure that takes no arguments
-;; and returns the tuple <i64,double,i32>*
-
-
-;; here's another tuple example
-;; note that my-test-7's return type is inferred
-;; by the tuple-reference index
-;; (i.e. i64 being tuple index 0)
-(xtmtest '(bind-func tuple-test2
- (lambda ()
- (let ((a:<i64,double>* (alloc)) ; returns pointer to type <i64,double>
- (b 37)
- (c 6.4))
- (tuple-set! a 0 b) ;; set i64 to 64
- (tset! a 1 c) ;; set double to 6.4 - tset! is an alias for tuple-set!
- (printf "tuple:1 %lld::%f\n" (tuple-ref a 0) (tref a 1))
- ;; we can fill a tuple in a single call by using tfill!
- (tfill! a 77 77.7)
- (printf "tuple:2 %lld::%f\n" (tuple-ref a 0) (tuple-ref a 1))
- (tuple-ref a 0))))
-
- (tuple-test2) 77)
-
-;; return first element which is i64
-;; should be 64 as we return the
-;; first element of the tuple
-;; (println (my-test-7)) ; 77
-
-
-;; tbind binds variables to values
-;; based on tuple structure
-;; _ (underscore) means don't attempt
-;; to match against this position in
-;; the tuple (i.e. skip)
-(xtmtest '(bind-func tuple-bind-test
- (lambda ()
- (let ((t1:<i32,float,<i32,float>*,double>* (alloc))
- (t2:<i32,float>* (alloc))
- (a 0) (b:float 0.0) (c 0.0))
- (tfill! t2 3 3.3)
- (tfill! t1 1 2.0 t2 4.0)
- (tbind t1 a b _ c)
- c)))
-
- (tuple-bind-test) 4.0)
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; some array code with *casting*
-;; this function returns void
-(xtmtest '(bind-func array-test1
- (lambda ()
- (let ((v1:|5,float|* (alloc))
- (v2:|5,float|* (alloc))
- (i 0)
- (k 0))
- (dotimes (i 5)
- ;; random returns double so "truncate" to float
- ;; which is what v expects
- (array-set! v1 i (dtof (random))))
- ;; we can use the afill! function to fill an array
- (afill! v2 1.1 2.2 3.3 4.4 5.5)
- (dotimes (k 5)
- ;; unfortunately printf doesn't like floats
- ;; so back to double for us :(
- (printf "val: %lld::%f::%f\n" k
- (ftod (array-ref v1 k))
- (ftod (aref v2 k)))))))
-
- (array-test1))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; some crazy array code with
-;; closures and arrays
-;; try to figure out what this all does
-;;
-;; this example uses the array type
-;; the pretty print for this type is
-;; |num,type| num elements of type
-;; |5,i64| is an array of 5 x i64
-;;
-;; An array is not a pointer type
-;; i.e. |5,i64| cannot be bitcast to i64*
-;;
-;; However an array can be a pointer
-;; i.e. |5,i64|* can be bitcast to i64*
-;; i.e. |5,i64|** to i64** etc..
-;;
-;; make-array returns a pointer to an array
-;; i.e. (make-array 5 i64) returns type |5,i64|*
-;;
-;; aref (array-ref) and aset! (array-set!)
-;; can operate with either pointers to arrays or
-;; standard pointers.
-;;
-;; in other words aref and aset! are happy
-;; to work with either i64* or |5,i64|*
-
-(bind-func array-test2
- (lambda (v:|5,i64|*)
- (let ((f (lambda (x)
- (* (array-ref v 2) x))))
- f)))
-
-(bind-func array-test3
- (lambda (v:|5,[i64,i64]*|*)
- (let ((ff (aref v 0))) ; aref alias for array-ref
- (ff 5))))
-
-(xtmtest '(bind-func array-test4
- (lambda ()
- (let ((v:|5,[i64,i64]*|* (alloc)) ;; make an array of closures!
- (vv:|5,i64|* (alloc)))
- (array-set! vv 2 3)
- (aset! v 0 (array-test2 vv)) ;; aset! alias for array-set!
- (array-test3 v))))
-
- ;; try to guess the answer before you call this!!
- (array-test4))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; some conditionals
-
-(xtmtest '(bind-func cond-test1
- (lambda (x:i64 y)
- (if (> x y)
- x
- y)))
-
- (cond-test1 12 13))
-
-;; returns boolean true
-(xtmtest '(bind-func cond-test2
- (lambda (x:i64)
- (cond ((= x 1) (printf "A\n"))
- ((= x 2) (printf "B\n"))
- ((= x 3) (printf "C\n"))
- ((= x 4) (printf "D\n"))
- (else (printf "E\n")))
- #t))
-
- (cond-test2 1))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; making a linear envelop generator
-;; for signal processing and alike
-
-(bind-func envelope-segments
- (lambda (points:double* num-of-points:i64)
- (let ((lines:[double,double]** (zone-alloc num-of-points))
- (k 0))
- (dotimes (k num-of-points)
- (let* ((idx (* k 2))
- (x1 (pointer-ref points (+ idx 0)))
- (y1 (pointer-ref points (+ idx 1)))
- (x2 (pointer-ref points (+ idx 2)))
- (y2 (pointer-ref points (+ idx 3)))
- (m (if (= 0.0 (- x2 x1)) 0.0 (/ (- y2 y1) (- x2 x1))))
- (c (- y2 (* m x2)))
- (l (lambda (time) (+ (* m time) c))))
- (pointer-set! lines k l)))
- lines)))
-
-(bind-func make-envelope
- (lambda (points:double* num-of-points)
- (let ((klines:[double,double]** (envelope-segments points num-of-points))
- (line-length num-of-points))
- (lambda (time)
- (let ((res -1.0)
- (k:i64 0))
- (dotimes (k num-of-points)
- (let ((line (pointer-ref klines k))
- (time-point (pointer-ref points (* k 2))))
- (if (or (= time time-point)
- (< time-point time))
- (set! res (line time)))))
- res)))))
-
-;; make a convenience wrapper
-(xtmtest '(bind-func env-wrap
- (let* ((points 3)
- (data:double* (zone-alloc (* points 2))))
- (pointer-set! data 0 0.0) ;; point data
- (pset! data 1 0.0)
- (pset! data 2 2.0)
- (pset! data 3 1.0)
- (pset! data 4 4.0)
- (pset! data 5 0.0)
- (let ((f (make-envelope data points)))
- (lambda (time:double)
- (f time)))))
- (env-wrap 0.0) 0.0)
-
-(xtmtest-result (env-wrap 1.0) 0.5)
-(xtmtest-result (env-wrap 2.0) 1.0)
-(xtmtest-result (env-wrap 2.5) 0.75)
-(xtmtest-result (env-wrap 4.0) 0.0)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; direct access to a closures environment
-;;
-;; it is possible to directly access a closures
-;; environment in order to read or modify data
-;; at runtime.
-;;
-;; You do this using a dot operator
-;; To access an environment slot you use
-;; closure.slot:type
-;; So for example
-;; (f.a:i32)
-;; would return the 32bit integer symbol 'a'
-;; from the closure 'f'
-;;
-;; To set an environment slot you just
-;; add a value of the correct type
-;; for example
-;; (f.a:i32 565)
-;; would set 'a' in 'f' to 565
-;;
-;; let's create a closure that capture's 'a'
-
-
-(xtmtest '(bind-func dot-access-test1
- (let ((a:i32 6))
- (lambda ()
- (printf "a:%d\n" a)
- a)))
- (dot-access-test1))
-
-;; now let's create a new function
-;; that calls my-test14 twice
-;; once normally
-;; then we directly set the closures 'a' binding
-;; then call again
-;;
-(xtmtest '(bind-func dot-access-test2
- (lambda (x:i32)
- (dot-access-test1)
- (dot-access-test1.a:i32 x)
- (dot-access-test1)))
-
- (dot-access-test2 9))
-
-;; of course this works just as well for
-;; non-global closures
-(xtmtest '(bind-func dot-access-test3
- (lambda (a:i32)
- (let ((f (lambda ()
- (* 3 a))))
- f)))
- (dot-access-test3 1))
-
-(xtmtest '(bind-func dot-access-test4
- (lambda ()
- (let ((f (dot-access-test3 5)))
- (f.a:i32 7)
- (f))))
-
- (dot-access-test4)
- 21)
-
-;; and you can get and set closures also!
-(xtmtest '(bind-func dot-access-test5
- (lambda ()
- (let ((f (lambda (x:i64) x)))
- (lambda (z)
- (f z)))))
-
- (dot-access-test5))
-
-(xtmtest '(bind-func dot-access-test6
- (lambda ()
- (let ((t1 (dot-access-test5))
- (t2 (dot-access-test5)))
- ;; identity of 5
- (printf "%lld:%lld\n" (t1 5) (t2 5))
- (t1.f:[i64,i64]* (lambda (x:i64) (* x x)))
- ;; square of 5
- (printf "%lld:%lld\n" (t1 5) (t2 5))
- ;; cube of 5
- (t2.f:[i64,i64]* (lambda (y:i64) (* y y y)))
- (printf "%lld:%lld\n" (t1 5) (t2 5))
- void)))
-
- (dot-access-test6)) ;; 5:5 > 25:5 > 25:125
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; named types
-
-;; it can sometimes be helpful to allocate
-;; a predefined tuple type on the stack
-;; you can do this using allocate
-(bind-type vec3 <double,double,double>)
-
-;; String printing!
-(bind-func vec3_print:[void,vec3*]*
- (lambda (x)
- (printf "<%d,%d,%d>" (tref x 0) (tref x 1) (tref x 2))
- void))
-
-(bind-poly print vec3_print)
-
-;; note that point is deallocated at the
-;; end of the function call. You can
-;; stack allocate (stack-alloc)
-;; any valid type (i64 for example)
-(xtmtest '(bind-func salloc-test
- (lambda ()
- (let ((point:vec3* (stack-alloc)))
- (tset! point 0 0.0)
- (tset! point 1 -1.0)
- (tset! point 2 1.0)
- 1)))
-
- (salloc-test)) ;; 1
-
-;; all named types have 2 default constructors
-;; name (zone alloation) + name_h (heap allocation)
-;; and a default print poly
-(xtmtest '(bind-func data-constructor-test
- (lambda ()
- (let ((v1 (vec3 1.0 2.0 3.0))
- (v2 (vec3_h 4.0 5.0 6.0)))
- (println v1 v2)
- ;; halloced vec3 needs freeing
- (free v2)
- void)))
-
- (data-constructor-test))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; aref-ptr and tref-ptr
-;;
-
-;; aref-ptr and tref-ptr return a pointer to an element
-;; just as aref and tref return elements aref-ptr and
-;; tref-ptr return a pointer to those elements.
-
-;; This allows you to do things like create an array
-;; with an offset
-(xtmtest '(bind-func aref-ptr-test
- (lambda ()
- (let ((arr:|32,i64|* (alloc))
- (arroff (aref-ptr arr 16))
- (i 0)
- (k 0))
- ;; load arr
- (dotimes (i 32) (aset! arr i i))
- (dotimes (k 16)
- (printf "index: %lld\tarr: %lld\tarroff: %lld\n"
- k (aref arr k) (pref arroff k))))))
-
- (aref-ptr-test))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; arrays
-;; Extempore lang supports arrays as for first class
-;; aggregate types (in other words as distinct from
-;; a pointer).
-;;
-;; an array is made up of a size and a type
-;; |32,i64| is an array of 32 elements of type i64
-;;
-
-(bind-type tuple-with-array <double,|32,|4,i32||,float>)
-
-(xtmtest '(bind-func array-test5
- (lambda ()
- (let ((tup:tuple-with-array* (stack-alloc))
- (t2:|32,i64|* (stack-alloc)))
- (aset! t2 0 9)
- (tset! tup 2 5.5)
- (aset! (aref-ptr (tref-ptr tup 1) 0) 0 0)
- (aset! (aref-ptr (tref-ptr tup 1) 0) 1 1)
- (aset! (aref-ptr (tref-ptr tup 1) 0) 2 2)
- (printf "val: %lld %lld %f\n"
- (aref (aref-ptr (tref-ptr tup 1) 0) 1)
- (aref t2 0) (ftod (tref tup 2)))
- (aref (aref-ptr (tref-ptr tup 1) 0) 1))))
-
- (array-test5) 1) ;; val: 1 9 5.5
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Global Variables
-;;
-;; You can allocate global variables using bind-val
-;;
-
-(bind-val g_var_a i32 5)
-
-;; increment g_var_a by inc
-;; and return new value of g_var_a
-(xtmtest '(bind-func global_var_test1
- (lambda (incr)
- (set! g_var_a (+ g_var_a incr))
- g_var_a))
-
- (global_var_test1 3) 8) ;; 8
-
-;; you can bind any primitive type
-(bind-val g_var_b double 5.5)
-(bind-val g_var_c i1 0)
-
-(xtmtest '(bind-func global_var_test1b
- (lambda ()
- (* g_var_b (if g_var_c 1.0 4.0))))
-
- (global_var_test1b) 22.0)
-
-;; global strings
-
-(bind-val g_cstring i8* "Jiblet.")
-
-(xtmtest '(bind-func test_g_cstring
- (lambda ()
- (let ((i 0))
- (dotimes (i 7)
- (printf "g_cstring[%lld] = %c\n" i (pref g_cstring i)))
- (printf "\nSpells... %s\n" g_cstring))))
-
- (test_g_cstring))
-
-(xtmtest '(bind-func test_g_cstring1
- (lambda ()
- (let ((test_cstring "Niblot.")
- (i 0)
- (total 0))
- (dotimes (i 7)
- (let ((c1 (pref g_cstring i))
- (c2 (pref test_cstring i)))
- (printf "checking %c against %c\n" c1 c2)
- (if (= c1 c2)
- (set! total (+ total 1)))))
- total)))
-
- (test_g_cstring1) 5)
-
-
-
-
-
-;; for tuples, arrays and vectors, bind-val only takes *two*
-;; arguments. The tuple/array/vector will be initialised to zero.
-
-(bind-val g_tuple1 <i64,i64>)
-(bind-val g_tuple2 <double,double>)
-
-(xtmtest '(bind-func test_g_tuple
- (lambda ()
- (tfill! g_tuple1 1 4)
- (tfill! g_tuple2 4.0 1.0)
- (and (= (tref g_tuple1 0) (dtoi64 (tref g_tuple2 1)))
- (= (dtoi64 (tref g_tuple2 0)) (tref g_tuple1 1)))))
-
- (test_g_tuple) 1)
-
-;; same thing with arrays
-
-(bind-val g_array1 |10,double|)
-(bind-val g_array2 |10,i64|)
-
-;; if we just loop over and print the values in each array
-
-(xtmtest '(bind-func test_g_array11
- (lambda ()
- (let ((i 0))
- (dotimes (i 10)
- (printf "garray_1[%lld] = %f garray_2[%lld] = %lld\n"
- i (aref g_array1 i) i (aref g_array2 i))))))
-
- (test_g_array11) 1)
-
-;; but if we loop over and set some values into the arrays
-
-(xtmtest '(bind-func test_g_array2
- (lambda ()
- (let ((i 0))
- (dotimes (i 10)
- (aset! g_array1 i (i64tod i))
- (aset! g_array2 i i)
- (printf "garray_1[%lld] = %f garray_2[%lld] = %lld\n"
- i (aref g_array1 i) i (aref g_array2 i)))
- (= (dtoi64 (aref g_array1 5))
- (aref g_array2 5)))))
-
- (test_g_array2) 1)
-
-;; just to test, let's try a large array
-
-(bind-val g_array3 |100000000,i64|)
-
-(xtmtest '(bind-func test_g_array3
- (lambda ()
- (let ((i 0))
- (dotimes (i 100000000)
- (aset! g_array3 i i))
- (= (pref g_array3 87654321)
- 87654321))))
-
- (test_g_array3) 1)
-
-;; if you want to bind a global pointer, then the third 'value'
-;; argument is the size of the memory to allocate (in elements, not in bytes)
-
-(bind-val g_ptr0 double* 10)
-
-(xtmtest '(bind-func test_g_ptr0
- (lambda ()
- (let ((total 0.0)
- (i 0))
- (dotimes (i 10)
- (pset! g_ptr0 i (i64tod i))
- (set! total (+ total (pref g_ptr0 i))))
- total)))
-
- (test_g_ptr0) 45.0)
-
-(bind-val g_ptr1 |4,i32|* 2)
-(bind-val g_ptr2 <i64,double>* 4)
-
-(xtmtest '(bind-func test_g_ptr1
- (lambda ()
- (afill! g_ptr1 11 66 35 81)
- (tset! g_ptr2 1 35.0)
- (printf "%f :: %d\n" (tref g_ptr2 1) (aref g_ptr1 2))
- (aref g_ptr1 3)))
-
- (test_g_ptr1) 81) ;; should also print 35.000000 :: 35
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Callbacks
-
-(xtmtest '(bind-func callback-test
- (lambda (time:i64 count:i64)
- (printf "time: %lld:%lld\n" time count)
- (callback (+ time 1000) callback-test (+ time 22050) (+ count 1))))
-
- (callback-test (now) 0))
-
-;; compiling this will stop the callbacks
-;;
-;; of course we need to keep the type
-;; signature the same [void,i64,i64]*
-;;
-(xtmtest '(bind-func callback-test
- (lambda (time:i64 count:i64)
- #t))
-
- (callback-test))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; some memzone tests
-
-(xtmtest '(bind-func memzone-test1
- (lambda ()
- (let ((b:|5,double|* (zalloc)))
- (aset! b 0
- (memzone 1024
- (let ((a:|10,double|* (zalloc)))
- (aset! a 0 3.5)
- (aref a 0))))
- (let ((c:|9,i32|* (zalloc)))
- (aset! c 0 99)
- (aref b 0)))))
-
- (memzone-test1) 3.5)
-
-(xtmtest '(bind-func memzone-test2
- (lambda ()
- (memzone 1024
- (let ((k:|15,double|* (zalloc))
- (f (lambda (fa:|15,double|*)
- (memzone 1024
- (let ((a:|10,double|* (zalloc))
- (i 0))
- (dotimes (i 10)
- (aset! a i (* (aref fa i) (random))))
- a)))))
- (f k)))))
-
- (memzone-test2))
-
-(xtmtest '(bind-func memzone-test3
- (lambda ()
- (let ((v (memzone-test2))
- (i 0))
- (dotimes (i 10) (printf "%lld:%f\n" i (aref v i))))))
-
- (memzone-test3)) ;; should print all 0.0's
-
-(xtmtest '(bind-func memzone-test4
- (lambda ()
- (memzone 1024 (* 44100 10)
- (let ((a:|5,double|* (alloc)))
- (aset! a 0 5.5)
- (aref a 0)))))
-
- (memzone-test4) 5.50000)
-
-;;
-;; Large allocation of memory on BUILD (i.e. when the closure is created)
-;; requires an optional argument (i.e. an amount of memory to allocate
-;; specifically for closure creation)
-;;
-;; This memory is automatically free'd whenever you recompile the closure
-;; (it will be destroyed and replaced by a new allocation of the
-;; same amount or whatever new amount you have allocated for closure
-;; compilation)
-;;
-(xtmtest '(bind-func closure-zalloc-test 1000000
- (let ((k:|100000,double|* (zalloc)))
- (lambda ()
- (aset! k 0 1.0)
- (aref k 0))))
-
- (closure-zalloc-test 1000000))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; Ad-Hoc Polymorphism
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; extempore supports ad-hoc polymorphism
-;; at some stage in the future this will
-;; be implicit - but for the moment
-;; it is explicitly defined using bind-poly
-
-;; ad-hoc polymorphism allows you to provide
-;; different specialisations depending on
-;; type. In other words, a single 'name'
-;; can be bound to multiple function
-;; implementations each with a uniqute
-;; type.
-
-
-;; poly variables can be for functions of
-;; mixed argument lengths
-;;
-;; so for example:
-(bind-func poly-test4
- (lambda (a:i8*)
- (printf "%s\n" a)))
-
-(bind-func poly-test5
- (lambda (a:i8* b:i8*)
- (printf "%s %s\n" a b)))
-
-(bind-func poly-test6
- (lambda (a:i8* b:i8* c:i8*)
- (printf "%s %s %s\n" a b c)))
-
-;; bind these three functions to poly 'print'
-(bind-poly testprint poly-test4)
-(bind-poly testprint poly-test5)
-(bind-poly testprint poly-test6)
-
-(xtmtest '(bind-func poly-test7
- (lambda ()
- (testprint "extempore's")
- (testprint "extempore's" "polymorphism")
- (testprint "extempore's" "polymorphism" "rocks")))
-
- (poly-test7))
-
-;; polys can Also specialize
-;; on the return type
-(bind-func poly-test8
- (lambda (a:double)
- (* a a)))
-
-(bind-func poly-test9
- (lambda (a:double)
- (dtoi64 (* a a))))
-
-(bind-poly sqrd poly-test8)
-(bind-poly sqrd poly-test9)
-
-;; specialize on [i64,double]*
-;;
-(xtmtest '(bind-func poly-test10:[i64,double]*
- (lambda (a)
- (+ 1 (sqrd a))))
- (poly-test10 5.0))
-
-;; specialize on [double,doube]*
-(xtmtest '(bind-func poly-test11:[double,double]*
- (lambda (a)
- (+ 1.0 (sqrd a))))
-
- (poly-test11 5.0))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; a little test for zone cleanup
-;;
-(bind-func MyLittleCleanupTest
- (lambda ()
- (let ((tmp2:i8* (alloc 8)))
- (cleanup (println "Clean up before leaving zone!"))
- tmp2)))
-
-(xtmtest '(bind-func cleanup-test
- (lambda ()
- (letz ((tmp:i8* (alloc 8))
- (t2 (MyLittleCleanupTest)))
- (begin
- (println "In Zone ...")
- 1))
- (println "Out of zone ...")
- void))
-
- (cleanup-test))
-
-;;;;;;;;;;;;;;;;;;
-;; vector types
-
-;; (bind-func vector-test1
-;; (lambda ()
-;; (let ((v1:/4,float/* (alloc))
-;; (v2:/4,float/* (alloc))
-;; (v3:/4,float/* (alloc)))
-;; (vfill! v1 4.0 3.0 2.0 1.0)
-;; (vfill! v2 1.0 2.0 3.0 4.0)
-;; (vfill! v3 5.0 5.0 5.0 5.0)
-;; (let ((v4 (* v1 v2))
-;; (v5 (> v3 v4))) ;; unforunately vector conditionals don't work!
-;; (printf "mul:%f:%f:%f:%f\n" (ftod (vref v4 0)) (ftod (vref v4 1)) (ftod (vref v4 2)) (ftod (vref v4 3)))
-;; (printf "cmp:%d:%d:%d:%d\n" (i1toi32 (vref v5 0)) (i1toi32 (vref v5 1)) (i1toi32 (vref v5 2)) (i1toi32 (vref v5 3)))
-;; void))))
-
-;; (test-xtfunc (vector-test1))
-
-(bind-func vector-test2
- (lambda ()
- (let ((v1:/4,float/* (alloc))
- (v2:/4,float/* (alloc)))
- (vfill! v1 1.0 2.0 4.0 8.0)
- (vfill! v2 2.0 2.5 2.25 2.125)
- (* v1 v2))))
-
-(xtmtest '(bind-func vector-test3
- (lambda ()
- (let ((a (vector-test2)))
- (printf "%f:%f:%f:%f\n"
- (ftod (vref a 0))
- (ftod (vref a 1))
- (ftod (vref a 2))
- (ftod (vref a 3)))
- void)))
-
- (vector-test3))
-
-;; vectorised sine func
-(bind-func vsinf4
- (let ((p:/4,float/* (alloc))
- (b:/4,float/* (alloc))
- (c:/4,float/* (alloc))
- (f1:/4,float/* (alloc))
- (f2:/4,float/* (alloc))
- (i:i32 0)
- (p_ 0.225)
- (b_ (dtof (/ 4.0 3.1415)))
- (c_ (dtof (/ -4.0 (* 3.1415 3.1415)))))
- (dotimes (i 4) (vset! p i p_) (vset! b i b_) (vset! c i c_))
- (lambda (x:/4,float/)
- ;; no SIMD for abs yet!
- (dotimes (i 4) (vset! f1 i (fabs (vref x i))))
- (let ((y (+ (* b x) (* c x f1))))
- ;; no SIMD for abs yet!
- (dotimes (i 4) (vset! f2 i (fabs (vref y i))))
- (+ (* p (- (* y f2) y)) y)))))
-
-(bind-func vcosf4
- (let ((p:/4,float/* (alloc))
- (b:/4,float/* (alloc))
- (c:/4,float/* (alloc))
- (d:/4,float/* (alloc))
- (f1:/4,float/* (alloc))
- (f2:/4,float/* (alloc))
- (i:i32 0)
- (p_ 0.225)
- (d_ (dtof (/ 3.1415 2.0)))
- (b_ (dtof (/ 4.0 3.1415)))
- (c_ (dtof (/ -4.0 (* 3.1415 3.1415)))))
- (dotimes (i 4)
- (vset! p i p_) (vset! b i b_) (vset! c i c_) (vset! d i d_))
- (lambda (x:/4,float/)
- ;; offset x for cos
- (set! x (+ x d))
- ;; no SIMD for abs yet!
- (dotimes (i 4) (vset! f1 i (fabs (vref x i))))
- (let ((y (+ (* b x) (* c x f1))))
- ;; no SIMD for abs yet!
- (dotimes (i 4) (vset! f2 i (fabs (vref y i))))
- (+ (* p (- (* y f2) y)) y)))))
-
-
-(xtmtest '(bind-func vector-test4
- (lambda ()
- (let ((a:/4,float/* (alloc)))
- (vfill! a 0.1 0.2 0.3 0.4)
- (let ((b (vsinf4 (pref a 0)))
- (c (vcosf4 (pref a 0))))
- (printf "precision inaccuracy is expected:\n")
- (printf " sinf:\t%f,%f,%f,%f\n"
- (ftod (sin 0.1:f))
- (ftod (sin 0.2:f))
- (ftod (sin 0.3:f))
- (ftod (sin 0.4:f)))
- (printf "vsinf:\t%f,%f,%f,%f\n"
- (ftod (vref b 0))
- (ftod (vref b 1))
- (ftod (vref b 2))
- (ftod (vref b 3)))
- (printf " cosf:\t%f,%f,%f,%f\n"
- (ftod (cos 0.1:f))
- (ftod (cos 0.2:f))
- (ftod (cos 0.3:f))
- (ftod (cos 0.4:f)))
- (printf "vcosf:\t%f,%f,%f,%f\n"
- (ftod (vref c 0))
- (ftod (vref c 1))
- (ftod (vref c 2))
- (ftod (vref c 3)))
- void))))
-
- (vector-test4))
-
-;; test the call-as-xtlang macro
-
-;; make sure it'll handle multiple body forms
-(xtmtest-result (call-as-xtlang (println 1) (println 2) 5)
- 5)
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;; test globalvar as closure
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(bind-func testinc
- (lambda (incr:i64)
- (lambda (x:i64)
- (+ x incr))))
-
-(bind-val GlobalInc [i64,i64]* (testinc 2))
-
-(xtmtest '(bind-func ginc
- (lambda ()
- (GlobalInc 5)))
- (ginc) 7)
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; syntax highlighting tests ;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; these don't return any values, they're visual tests---do they look
-;; right?
-
-(bind-func hl_test1a:[i32,double,|4,i32|**]* 4000
- "docstring"
- (lambda (a b)
- (printf "done\n")))
-
-(bind-func hl_test1b:[i32]*
- (lambda ()
- (let ((i:i32 6))
- (printf "done\n"))))
-
-(bind-val hl_test2 <i32,i32>)
-(bind-val hl_test3 |4,i8|)
-(bind-val hl_test4 double* 10)
-(bind-val hl_test5 i8* "teststr")
-
-(bind-type hl_test_type <i64>)
-
-(println '(bind-lib testlib testfn [i32,i32]*))
-
-;; (and 4 5)
-;; (bind-val hl_test4 double* 10)
-;; (bind-type hl_test_type <i64> "docstring")
-;; (bind-lib testlib testfn [i32,i32]*)
View Lorry Controller Status