1101 lines
31 KiB
Text
1101 lines
31 KiB
Text
;;; 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]*)
|