/examples/extempore_lang.scm

  1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2;;
  3;;  A basic introduction to the Extempore Language and Compiler
  4;;
  5;;  These examples are specific to Extempore lang
  6;;  for versions of LLVM v3.0+
  7;;
  8;;
  9
 10;; multiple a * 5
 11;; note that type infercing works out the type 
 12;; of "a" and then using the inferred type
 13;; also works out the type of my-test-1
 14;; (i.e. argument type and return type)
 15;; 
 16;; integer literals default to 64 bit integers
 17(definec my-test-1
 18   (lambda (a)
 19      (* a 5)))
 20
 21;; notice that the log view displays the type
 22;; of the closure we just compiled
 23;; [i64,i64]*
 24;; The square brackets define a closure type
 25;; The first type within the square braces is
 26;; the return type of the function (i64 for 64bit integer)
 27;; Any remaining types are function arguments 
 28;; in this case another i64 (for 64bit integer)
 29;; 
 30;; All closures are pointers.  Pointer types are
 31;; represented (as in "C") with a "*" which trails
 32;; the base type.
 33;; So a pointer to a 64 bit integer would be "i64*"
 34;; A double pointer type would be "double*"
 35;; So a closure pointer type is "[...]*"
 36
 37;; float literals default to doubles
 38(definec my-test-1f
 39   (lambda (a)
 40      (* a 5.0)))
 41
 42;; Again note the closures type in the logview
 43;; [double,double]*
 44;; a closure that returns a double and
 45;; taks a double as it's only argument
 46
 47
 48;; we can call these new closures like so
 49;; making sure we pass an integer for my-test-1
 50(println (my-test-1 6)) ;; 30
 51;; and a real number for my-test-1f
 52(println (my-test-1f 6.0)) ;; 30.0
 53
 54
 55;; you are free to recompile an existing closure
 56;; so we can change my-test-1 to
 57(definec my-test-1
 58   (lambda (a)
 59      (/ a 5)))
 60
 61(println (my-test-1 30)) ; 30 / 5 = 6
 62
 63;; note that the closures signature is still the same
 64;; as it was before.  This is important because we are
 65;; NOT allowed to change an existing compiled closures
 66;; type signature.
 67;; 
 68;; So we CANNOT do this
 69
 70;(definec my-test-1
 71;   (lambda (a)
 72;      (/ a 5.0)))
 73
 74;; Just remember that you are not currently allowed to redefine an 
 75;; existing function to a new definition that requres a different type signature.  
 76;; This is to protect against the situation where you have allready compiled
 77;; code which requires the current signature.
 78
 79
 80;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 81;; Because we are working with closures
 82;; we can "close" over free variables
 83;; in this example we close over power
 84;; to maintain state between calls
 85;;
 86;; increment power each call
 87(definec my-test-2
 88   (let ((power 0))
 89      (lambda (x)
 90         (set! power (+ power 1)) ;; set! for closure mutation as per scheme
 91         (* x power))))
 92
 93;; each modifies state
 94(println (my-test-2 2)) ;; should = 2
 95(println (my-test-2 2)) ;; should = 4
 96(println (my-test-2 2)) ;; etc
 97
 98               
 99;; Closures can of course return closures.
100;; notice the type signature of this closure
101;; as printed in the logview "[[i64,i64]*]*"
102;; being a closure that returns a closure
103;; the outer closure takes no arguments
104;; and the return closure takes an i64 argument
105(definec my-test-3
106  (lambda ()
107    (lambda (x)
108      (* x 3))))
109
110
111;; let's try to make a generic incrementor
112;;
113;; here we run into trouble
114;; because the type inferencer cannot infer a valid type 
115;; for i or inc because there are no numberic literals
116;; to help in the validation process
117
118;; THIS WOULD CAUSE AN ERROR!
119;(definec my-inc-maker
120;  (lambda (i)
121;    (lambda (inc)
122;      (set! i (+ i inc))
123;      i)))
124
125;; This makes sense - should "+" operate
126;; on doubles or integers - who knows?
127;; So the type inferencer justifiably complains
128;;
129;; What can we do about this ... 
130;; we need to help the compiler out by providing
131;; some explicit type information
132;;
133;; We can do that by "typing" a variable.
134;; Explicitly typing a variable means tagging
135;; the symbol with a type separated by ":"
136;;
137;; Here are some examples
138;; x:i64        = x is a 64 bit integer
139;; y:double     = y is a double
140;; z:i32*       = z is a pointer to a 32 bit integer
141;; w:[i64,i64]* = w is a closure which takes an i64 and returns an i64
142;;                (remember that closures are ALWAYS pointers it is not
143;;                 valid to have a closure type which is NOT a pointer)
144
145;;
146;; With this information in mind we can
147;; fix the incrementor by explicitly typing 'i'
148(definec my-inc-maker
149   (lambda (i:i64)
150      (lambda (inc)
151         (set! i (+ i inc))
152         i)))
153
154;; this solves our problem as the compiler
155;; can now use i's type to infer inc and
156;; therefore my-inc-maker.
157
158;; now we have a different problem.
159;; if we call my-inc-maker we expect to be 
160;; returned a closure.  However Scheme does not
161;; know anything about Extempore Lang closure types and therefore
162;; has no way of using the returned data.
163
164;; Instead it places the returned pointer
165;; (remember a closure is a pointer)
166;; into a generic Scheme cptr type.
167;; All pointer types moving from Extempore Lang -> Scheme
168;; are converted into generic Scheme cptr types.  Scheme
169;; knows that the type is a cptr but has no further information.
170;;
171;;
172;; We are free to then pass that cptr back into another
173;; compiled Extempore Lang function as an argument. When moving
174;; from Scheme -> Extempore Lang the generic Scheme cptr is
175;; automatically converted back into the explicit pointer type
176;; required by Extempore Lang.
177;; IMPORTANT!: This conversion is automatic and UNCHECKED so
178;; it is your responsibility to ensure that Scheme cptr's point
179;; to appropriate data (i.e. appropriate for the function be
180;; called in Extempore Lang).
181
182;; So let's build a function that excepts a closure returned from 
183;; my-inc-maker as an argument, as well as a suitable operand, and 
184;; apply the closure.
185
186;; f is our incoming closure
187;; and x is our operand
188;; THIS WILL CAUSE AN ERROR
189
190;(definec my-inc-maker-wrappert
191;   (lambda (f x) ; f and x are args
192;      (f x)))
193
194;; oops can't resolve the type of "f"
195;; fair enough really.
196;; even if we give a type for "x"
197;; we still can't tell what "f"'s
198;; return type should be?
199;; This also causes an error!
200
201;(definec my-inc-maker-wrappert
202;   (lambda (f x:i64) ; f and x are args
203;      (f x)))
204
205;; so we need to type f properly
206(definec my-inc-maker-wrapper
207   (lambda (f:[i64,i64]* x)      
208      (f x)))
209
210;; ok so now we can call my-inc-maker
211;; which will return a closure
212;; which scheme stores as a generic cptr
213(define myf (my-inc-maker 0))
214
215;; and we can call my-in-maker-wrapper
216;; to appy myf
217(println (my-inc-maker-wrapper myf 1)) ; 1
218(println (my-inc-maker-wrapper myf 1)) ; 2
219(println (my-inc-maker-wrapper myf 1)) ; 3 etc..
220
221;; of course the wrapper is only required if you 
222;; need interaction with the scheme world.
223;; otherwise you just call my-inc-maker directly
224
225;; this avoids the wrapper completely
226(definec my-inc-test
227   (let ((f (my-inc-maker 0)))
228      (lambda ()
229         (f 1))))
230
231(println (my-inc-test)) ; 1
232(println (my-inc-test)) ; 2
233(println (my-inc-test)) ; 3
234
235;; hopefully you're getting the idea.
236;; note that once we've compiled something
237;; we can then use it any of our new
238;; function definitions.
239
240
241;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
242;;
243;; Closures can be recursive
244;;
245
246(definec my-test-4
247  (lambda (a)
248    (if (< a 1)
249	(printf "done\n")
250	(begin (printf "a: %lld\n" a)
251	       (my-test-4 (- a 1))))))
252
253(my-test-4 7)
254    
255
256;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
257;; a simple tuple example
258;; 
259;; tuple types are represented as <type,type,type>*
260;;
261
262;; make and return a simple tuple
263(definec my-test-6
264  (lambda ()
265    (alloc <i64,double,i32>)))
266
267
268;; logview shows [<i64,double,i32>*]*
269;; i.e. a closure that takes no arguments
270;; and returns the tuple <i64,double,i32>*
271      
272
273;; here's another tuple example
274;; note that my-test-7's return type is inferred
275;; by the tuple-reference index 
276;; (i.e. i64 being tuple index 0)
277(definec my-test-7 
278  (lambda ()
279    (let ((a (alloc <i64,double>)) ; returns pointer to type <i64,double>
280	  (b 37)
281	  (c 6.4))
282      (tuple-set! a 0 b) ;; set i64 to 64
283      (tset! a 1 c) ;; set double to 6.4 - tset! is an alias for tuple-set!
284      (printf "tuple:1 %lld::%f\n" (tuple-ref a 0) (tref a 1))
285      ;; we can fill a tuple in a single call by using tfill!
286      (tfill! a 77 77.7)
287      (printf "tuple:2 %lld::%f\n" (tuple-ref a 0) (tuple-ref a 1))
288      (tuple-ref a 0)))) ;; return first element which is i64
289
290;; should be 64 as we return the 
291;; first element of the tuple 
292(println (my-test-7)) ; 77
293
294
295;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
296;; some array code with *casting*
297;; this function returns void
298(definec my-test-8
299   (lambda ()
300      (let ((v1 (alloc |5,float|))
301	    (v2 (alloc |5,float|))
302	    (i 0)
303	    (k 0))
304         (dotimes (i 5)
305            ;; random returns double so "truncate" to float
306            ;; which is what v expects
307            (array-set! v1 i (dtof (random))))
308	 ;; we can use the afill! function to fill an array
309	 (afill! v2 1.1 2.2 3.3 4.4 5.5)
310         (dotimes (k 5)
311            ;; unfortunately printf doesn't like floats
312            ;; so back to double for us :(
313            (printf "val: %lld::%f::%f\n" k
314		    (ftod (array-ref v1 k))
315		    (ftod (aref v2 k)))))))
316
317(my-test-8)
318
319;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
320;; some crazy array code with
321;; closures and arrays
322;; try to figure out what this all does
323;;
324;; this example uses the array type
325;; the pretty print for this type is
326;; |num,type| num elements of type
327;; |5,i64| is an array of 5 x i64
328;;
329;; An array is not a pointer type
330;; i.e. |5,i64| cannot be bitcast to i64*
331;;
332;; However an array can be a pointer
333;; i.e. |5,i64|* can be bitcast to i64*
334;; i.e. |5,i64|** to i64** etc..
335;;
336;; make-array returns a pointer to an array
337;; i.e. (make-array 5 i64) returns type |5,i64|*
338;;
339;; aref (array-ref) and aset! (array-set!)
340;; can operate with either pointers to arrays or
341;; standard pointers.
342;;
343;; in other words aref and aset! are happy
344;; to work with either i64* or |5,i64|*
345
346(definec my-test-9
347   (lambda (v:|5,i64|*)
348      (let ((f (lambda (x)
349                  (* (array-ref v 2) x))))
350         f)))
351
352(definec my-test-10
353  (lambda (v:|5,[i64,i64]*|*)
354    (let ((ff (aref v 0))) ; aref alias for array-ref
355      (ff 5))))
356
357
358(definec my-test-11
359   (lambda ()
360      (let ((v (alloc |5,[i64,i64]*|)) ;; make an array of closures!
361            (vv (alloc |5,i64|)))
362         (array-set! vv 2 3)
363         (aset! v 0 (my-test-9 vv)) ;; aset! alias for array-set!
364         (my-test-10 v))))
365
366;; try to guess the answer before you call this!!
367(println (my-test-11))
368
369;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
370;; some conditionals
371
372(definec my-test-12
373   (lambda (x:i64 y)
374      (if (> x y)
375          x
376          y)))
377
378(println (my-test-12 12 13))
379(println (my-test-12 13 12))
380
381;; returns boolean true
382(definec my-test-13
383   (lambda (x:i64)
384      (cond ((= x 1) (printf "A\n"))
385            ((= x 2) (printf "B\n"))
386            ((= x 3) (printf "C\n"))
387            ((= x 4) (printf "D\n"))
388            (else (printf "E\n")))
389      #t))
390            
391(my-test-13 1)
392(my-test-13 3)
393(my-test-13 100)
394
395
396;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
397;; making a linear envelop generator
398;; for signal processing and alike
399
400(definec envelope-segments
401  (lambda (points:double* num-of-points:i64)
402    (let ((lines (zone-alloc num-of-points [double,double]*))
403	  (k 0))
404      (dotimes (k num-of-points)
405	(let* ((idx (* k 2))
406	       (x1 (pointer-ref points (+ idx 0)))
407	       (y1 (pointer-ref points (+ idx 1)))
408	       (x2 (pointer-ref points (+ idx 2)))
409	       (y2 (pointer-ref points (+ idx 3)))
410	       (m (if (= 0.0 (- x2 x1)) 0.0 (/ (- y2 y1) (- x2 x1))))
411	       (c (- y2 (* m x2)))
412	       (l (lambda (time) (+ (* m time) c))))
413	  (pointer-set! lines k l)))
414      lines)))
415
416
417(definec make-envelope
418   (lambda (points:double* num-of-points)
419      (let ((klines:[double,double]** (envelope-segments points num-of-points))
420            (line-length num-of-points))
421         (lambda (time)
422            (let ((res -1.0)
423		  (k:i64 0))
424               (dotimes (k num-of-points)
425                  (let ((line (pointer-ref klines k))
426                        (time-point (pointer-ref points (* k 2))))
427                     (if (or (= time time-point)
428                             (< time-point time))
429                         (set! res (line time)))))
430               res)))))
431
432
433;; make a convenience wrapper 
434(definec env-wrap
435   (let* ((points 3)
436          (data (zone-alloc (* points 2) double)))
437      (pointer-set! data 0 0.0) ;; point data
438      (pset! data 1 0.0)      
439      (pset! data 2 2.0)
440      (pset! data 3 1.0)      
441      (pset! data 4 4.0)
442      (pset! data 5 0.0)
443      (let ((f (make-envelope data points)))
444         (lambda (time:double)
445            (f time)))))
446
447(println (env-wrap 0.0)) ;; time 0.0 should give us 0.0
448(println (env-wrap 1.0)) ;; time 1.0 should give us 0.5
449(println (env-wrap 2.0)) ;; time 2.0 should be 1.0
450(println (env-wrap 2.5)) ;; going back down 0.75
451(println (env-wrap 4.0)) ;; to zero
452
453
454;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
455;;
456;; direct access to a closures environment
457;;
458;; it is possible to directly access a closures
459;; environment in order to read or modify data
460;; at runtime.
461;;
462;; You do this using a dot operator
463;; To access an environment slot you use
464;; closure.slot:type
465;; So for example
466;; (f.a:i32)
467;; would return the 32bit integer symbol 'a'
468;; from the closure 'f'
469;; 
470;; To set an environment slot you just
471;; add a value of the correct type
472;; for example
473;; (f.a:i32 565)
474;; would set 'a' in 'f' to 565
475;; 
476;; let's create a closure that capture's 'a'
477
478
479(definec my-test14
480  (let ((a:i32 6))
481    (lambda ()
482      (printf "a:%d\n" a)
483      a)))
484
485;; calling my-test14 prints the value of a
486;; and returns the bind to a (i.e. 6)
487(my-test14) ;  6
488
489
490;; now let's create a new function
491;; that calls my-test14 twice
492;; once normally
493;; then we directly set the closures 'a' binding
494;; then call again
495;; 
496(definec my-test15
497  (lambda (x:i32)
498    (my-test14)
499    (my-test14.a:i32 x)
500    (my-test14)))
501
502;; should print a:6 and a:9
503(my-test15 9) ; 9
504
505;; now what happens if we pass 101
506;; should print a:9 and a:101
507(my-test15 101) ; 101
508
509
510
511;; of course this works just as well for
512;; non-global closures
513(definec my-test16
514  (lambda (a:i32)
515    (let ((f (lambda ()
516	       (* 3 a))))
517      f)))
518
519(definec my-test17
520  (lambda ()
521    (let ((f (my-test16 5)))
522      (f.a:i32 7)
523      (f))))
524
525(println (my-test17)) ;; 21
526
527
528
529;; and you can get and set closures also!
530(definec my-test18
531  (let ((f (lambda (x:i64) x)))
532    (lambda ()
533      (lambda (z)
534	(f z)))))
535
536
537(definec my-test19
538  (lambda ()
539    (let ((t1 (my-test18))
540	  (t2 (my-test18)))
541      ;; identity of 5
542      (printf "%lld:%lld\n" (t1 5) (t2 5))
543      (t1.f:[i64,i64]* (lambda (x:i64) (* x x)))
544      ;; square of 5
545      (printf "%lld:%lld\n" (t1 5) (t2 5))      
546      ;; cube of 5 
547      (my-test18.f:[i64,i64]* (lambda (y:i64) (* y y y)))
548      (printf "%lld:%lld\n" (t1 5) (t2 5)))))
549
550
551(my-test19) ;; 5:5 > 25:25 > 125:125
552
553
554
555;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
556;;
557;; named types
558
559;; we can name our own types using bind-type
560(bind-type mytype <i64,i64>)
561
562;; which we can then use in place
563(definec my-test20
564  (lambda (a:mytype*)
565    (tref a 0)))
566
567;; named types support recursion
568(bind-type i64list <i64,i64list*>)
569
570;; Note the use of zone-alloc to allocate
571;; enough zone memory to hold an i64list
572;; zone-alloc returns a pointer to the
573;; type that you ask it to allocate
574;; pair is type i64list* in this case.
575;;
576;; You are responsible for cleaning up
577;; this memory at some point in the future!
578;; (i.e. cleaning up the memory zone that this
579;; heap allocation was made into)
580(definec cons-i64
581  (lambda (a:i64 b:i64list*)
582    (let ((pair (zone-alloc i64list)))
583      (tset! pair 0 a)
584      (tset! pair 1 b)
585      pair)))
586          
587(definec car-i64
588  (lambda (a:i64list*)
589    (tref a 0)))
590
591(definec cdr-i64
592  (lambda (a:i64list*)
593    (tref a 1)))
594
595;; print all i64's in list
596(definec my-test25
597  (lambda (a:i64list*)
598    (if (null? a)
599	(begin (printf "done\n") 1)
600	(begin (printf "%lld\n" (car-i64 a))
601	       (my-test25 (cdr-i64 a))))))
602
603;; build a list (using cons) and then call my-test25
604(definec my-test26
605  (lambda ()
606    (let ((my-list (cons-i64 1 (cons-i64 2 (cons-i64 3 null)))))
607      (my-test25 my-list))))
608
609(my-test26) ;; 1 > 2 > 3 > done
610
611
612;; it can sometimes be helpful to allocate
613;; a predefined tuple type on the stack
614;; you can do this using allocate
615(bind-type vec3 <double,double,double>)
616
617;; note that point is deallocated at the
618;; end of the function call.  You can
619;; stack allocate (stack-alloc)
620;; any valid type  (i64 for example)
621(definec my-test27
622  (lambda ()
623    (let ((point (stack-alloc vec3)))
624      (tset! point 0 0.0)
625      (tset! point 1 -1.0)
626      (tset! point 2 1.0)
627      1)))
628
629(println (my-test27)) ;; 1
630
631
632;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
633;;
634;; aref-ptr and tref-ptr
635;;
636
637;; aref-ptr and tref-ptr return a pointer to an element
638;; just as aref and tref return elements aref-ptr and
639;; tref-ptr return a pointer to those elements.
640
641;; This allows you to do things like create an array
642;; with an offset
643(definec my-test28
644  (lambda ()
645    (let ((arr (alloc |32,i64|))
646	  (arroff (aref-ptr arr 16))
647	  (i 0)
648	  (k 0))
649      ;; load arr
650      (dotimes (i 32) (aset! arr i i))
651      (dotimes (k 16)
652	(printf "index: %lld\tarr: %lld\tarroff: %lld\n"
653		k (aref arr k) (pref arroff k))))))
654      
655(my-test28) ;; print outs
656
657
658;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
659;;
660;; arrays
661;; Extempore lang supports arrays as for first class
662;; aggregate types (in other words as distinct from
663;; a pointer).
664;;
665;; an array is made up of a size and a type
666;; |32,i64| is an array of 32 elements of type i64 
667;;
668
669(bind-type tuple-with-array <double,|32,|4,i32||,float>)
670
671(definec my-test29
672  (lambda ()
673    (let ((tup (stack-alloc tuple-with-array))
674	  (t2 (stack-alloc |32,i64|)))
675      (aset! t2 0 9)      
676      (tset! tup 2 5.5)
677      (aset! (aref-ptr (tref-ptr tup 1) 0) 0 0)
678      (aset! (aref-ptr (tref-ptr tup 1) 0) 1 1)
679      (aset! (aref-ptr (tref-ptr tup 1) 0) 2 2)
680      (printf "val: %lld %lld %f\n"
681	      (aref (aref-ptr (tref-ptr tup 1) 0) 1)
682	      (aref t2 0) (ftod (tref tup 2)))
683      (aref (aref-ptr (tref-ptr tup 1) 0) 1))))
684
685(my-test29) ;; val: 1 9 5.5
686
687
688;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
689;;
690;; Global Variables
691;;
692;; You can allocate global variables using bind-val
693;;
694
695(bind-val g-var-a i32 5)
696
697;; increment g-var-a by inc
698;; and return new value of g-var-a
699(definec my-test30
700  (lambda (inc)
701    (set! g-var-a (+ g-var-a inc))
702    g-var-a))
703
704(println (my-test30 3)) ;; 8
705
706;; you can bind any primitive type
707(bind-val g-var-b double 5.5)
708(bind-val g-var-c i1 0)
709
710;; you can bind array types
711;; and choose to either
712;; a) assign a value to each element
713(bind-val g-var-a1 |5,i64| (list 1 2 3 4 5))
714;; or b) assign a default value to all elements
715;; for example initialize all 1024 double elements to 5.125
716(bind-val g-var-a2 |1024,double| 5.125)
717
718(definec test31
719  (lambda ()
720    (printf "a1[3]:%lld  a2[55]:%f\n" (aref g-var-a1 3) (aref g-var-a2 55))
721    1))
722
723(test31)
724
725;; finally you can use sys:make-cptr to allocate
726;; memory to any ptr type you like. It is up to
727;; you to however to ensure that you allocate an
728;; appropriate amount of space.
729(bind-val g-var-d |4,i32|* (sys:make-cptr (* 4 4)))
730(bind-val g-var-e tuple-with-array* (sys:make-cptr (+ 8 (* 32 (* 4 4)) 4)))
731
732(definec test32
733  (lambda ()
734    (tset! g-var-e 0 11.0)
735    (aset! g-var-d 0 55)
736    (printf "%f :: %d\n" (tref g-var-e 0) (aref g-var-d 0))
737    1))
738
739(test32) ;; 11.000 :: 55
740
741
742(bind-val gvar-array |5,double| 0.0)
743
744(definec test33
745  (lambda ()
746    (aset! gvar-array 3 19.19)
747    (aref gvar-array 3)))
748
749(println (test33)) ;; -> 19.19
750
751
752;; End Of Tutorial
753(print)
754(println 'finished)
755
756
757
758;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
759;;
760;; Callbacks
761
762(definec test34
763  (lambda (time:i64 count:i64)
764    (printf "time: %lld:%lld\n" time count)
765    (callback (+ time 1000) test34 (+ time 22050) (+ count 1))))
766
767(test34 (now) 0)
768
769
770;; compiling this will stop the callbacks
771;;
772;; of course we need to keep the type
773;; signature the same [void,i64,i64]*
774;;
775(definec test34
776  (lambda (time:i64 count:i64)
777    void))
778
779
780;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
781;;
782;; some memzone tests
783
784(definec test35
785  (lambda ()
786    (let ((b (zalloc |5,double|)))
787      (aset! b 0
788	(memzone 1024
789	   (let ((a (zalloc |10,double|)))
790	     (aset! a 0 3.5)
791	     (aref a 0))))
792      (let ((c (zalloc |9,i32|)))
793	(aset! c 0 99)
794	(aref b 0)))))
795
796
797(println (test35)) ;; 3.5
798
799
800(definec test36
801  (lambda ()
802    (memzone 1024
803      (let ((k (zalloc |15,double|))
804	    (f (lambda (fa:|15,double|*)
805	         (memzone 1024
806		   (let ((a (zalloc |10,double|))
807			 (i 0))
808		     (dotimes (i 10)
809		       (aset! a i (* (aref fa i) (random))))
810		   a)))))
811	(f k)))))
812
813(definec test37
814  (lambda ()
815    (let ((v (test36))
816	  (i 0))
817      (dotimes (i 10) (printf "%lld:%f\n" i (aref v i))))))
818
819;; should print all 0.0's  
820(test37)
821
822
823(definec test38
824  (lambda ()
825    (memzone 1024 (* 44100 10)
826      (let ((a (alloc |5,double|)))
827	(aset! a 0 5.5)
828	(aref a 0)))))
829
830(println (test38)) ;; 5.50000
831	     
832
833;;
834;; Large allocation of memory on BUILD (i.e. when the closure is created)
835;; requires an optional argument (i.e. an amount of memory to allocate
836;; specifically for closure creation)
837;;
838;; This memory is automatically free'd whenever you recompile the closure
839;; (it will be destroyed and replaced by a new allocation of the
840;;  same amount or whatever new amount you have allocated for closure
841;;  compilation)
842;;
843(definec test39 1000000
844  (let ((k (zalloc |100000,double|)))
845    (lambda ()
846      (aset! k 0 1.0)
847      (aref k 0))))
848
849
850
851
852;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
853;;
854;; Some data structures examples
855
856
857;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
858;;
859;; FIFO Queue for positive 64bit integers
860;;
861;; i8* is value  --- list_t* is next
862(bind-type list_t <i64,list_t*>)
863
864;; remove value from front of list
865(definec dequeue
866  (lambda (queue:|2,list_t*|*)
867    (let ((front (aref queue 0)))
868      (if (null? front) -1
869	  (let ((val (tref front 0))
870		(back (aref queue 1)))
871	    (aset! queue 0 (tref front 1))
872	    (if (= back front) (aset! queue 1 null))
873	    (free front)
874	    val)))))
875
876;; add to the back of the list
877(definec enqueue
878  (lambda (queue:|2,list_t*|* value:i64)
879    (let ((tmp (halloc list_t))
880	  (front (aref queue 0))
881	  (back (aref queue 1)))
882      (tset! tmp 0 value)
883      (tset! tmp 1 null)
884      (if (null? back) 1 (begin (tset! back 1 tmp) 1))
885      (if (null? front) (aset! queue 0 tmp))
886      (aset! queue 1 tmp) ;; set back to tmp
887      1)))
888
889(definec queue_test
890  (lambda ()
891    (let ((myqueue (salloc |2,list_t*|))
892	  (stuff (salloc |8,i64|))
893	  (i 0))
894      ;; first we must set queue front and back to null
895      (afill! myqueue null null)
896      ;; initialize stuff array
897      (dotimes (i 8) (aset! stuff i i))
898      ;; what happens if we dequeue an empty queue (-1)
899      (printf "dequeue 1: %lld\n" (dequeue myqueue))
900      ;; add something to the queue
901      (enqueue myqueue (aref stuff 1))
902      ;; dequeue something
903      (printf "dequeue 2: %lld\n" (dequeue myqueue))
904      ;; back to nothing?
905      (printf "dequeue 4: %lld\n" (dequeue myqueue))
906      ;; etc..
907      (enqueue myqueue (aref stuff 2))
908      (printf "dequeue 5: %lld\n" (dequeue myqueue))
909      (enqueue myqueue (aref stuff 3))
910      (enqueue myqueue (aref stuff 4))
911      (printf "dequeue 6: %lld\n" (dequeue myqueue))
912      (printf "dequeue 7: %lld\n" (dequeue myqueue))
913      (printf "dequeue 8: %lld\n" (dequeue myqueue))      
914      1)))
915
916(queue_test)
917
918
919
920
921
922
923
924
925
926
927
928
929;; Memory Usage In Extempore Lang
930;; -------------------------------
931
932;; Extempore supports three types of memory allocation: stack allocation,
933;; heap alloation and zone allocation.  The first two of these memory
934;; allocation techniques should be familiar to anyone who has programmed
935;; in C/C++.  The third allocation type represents a type of middle ground
936;; between these two extremes.  Zone allocation in Extempore is in essence
937;; a form of stack allocation whose scope is defined by the user.
938
939;; Stack allocation in extempore is identical to stack allocation in C.
940;; Stack allocation is made using the stack-alloc call (or salloc for
941;; short).  Stack allocations, as in C, are available only for the
942;; duration of the function call.  They are deallocated when the function
943;; returns.
944
945;; (definec ex1
946;;   (lambda ()
947;;     (let ((a (stack-alloc double)))
948;;       (aset! a 0 5.5)
949;;       (aref a 0))))
950
951;; This example demonstrates a stack allocation of a single double (8
952;; bytes) bound to the symbol a. The type returned by stack-alloc is
953;; always a pointer to the memory allocated.  In ex1 the instance 'a'
954;; will be of type double* (a:double*).  An optional integer argument
955;; before the requested type results in a multiple allocation.
956
957;; (bind-type vec3 <float,float,float>)
958
959;; (definec ex2
960;;   (lambda ()
961     
962
963
964
965;; ;; calls that draw memory from the current zone
966
967;; make-string (literal strings are constant heap allocations)
968;; closures (i.e. lambda)
969;; make-array
970;; make-tuple
971;; zone-alloc
972
973;; ;; call that draw memory from the stack
974;; stack-alloc
975;; just about everything else
976
977;; ;; calls that draw memory from the heap
978;; heap-alloc