Some more instructions tested, added reentrant call's that are needed for instruction...
[aschm:aschm.git] / rtl.scm
1 (use-modules (system vm rtl))
2 (use-modules (native vm constants))
3 (use-modules (native vm c-callers))
4 (use-modules (native vm init)) 
5 (use-modules (native vm jit)) 
6 (use-modules (native aschm)) 
7 (use-modules (native vm c-call)) 
8 (use-modules (native vm vm)) 
9 (use-modules (native vm inject))
10
11 (define foo 
12   ((assemble-program 
13     `((begin-program foo)
14       (assert-nargs-ee/locals 0 1)
15       (load-static-procedure 0 bar)
16       (return 0)
17       (end-program)
18       (begin-program bar)
19       (assert-nargs-ee/locals 0 1)
20       (load-constant 0 42)
21       (return 0)
22       (end-program)))))
23
24
25 (define accum
26   ((assemble-program
27     ;; 0: elt
28     ;; 1: tail
29     ;; 2: head
30     '((begin-program make-accum)
31       (assert-nargs-ee/locals 0 2)
32       (load-constant 0 0)
33       (box 0 0)
34       (make-closure 1 accum (0))
35       (return 1)
36       (end-program)
37       (begin-program accum)
38       (assert-nargs-ee/locals 1 2)
39       (free-ref 1 0)
40       (box-ref 2 1)
41       (add 2 2 0)
42       (box-set! 1 2)
43       (return 2)
44       (end-program)))))
45
46 (define sumto
47   (assemble-program
48    ;; 0: limit
49    ;; 1: n
50    ;; 2: accum
51    '((begin-program countdown)
52      (assert-nargs-ee/locals 1 2)
53      (br fix-body)
54      (label loop-head)
55      (br-if-= 1 0 out)
56      (add 2 1 2)
57      (add1 1 1)
58      (br loop-head)
59      (label fix-body)
60      (load-constant 1 0)
61      (load-constant 2 0)
62      (br loop-head)
63      (label out)
64      (return 2)
65      (end-program))))
66
67 (define test1
68   (assemble-program
69    '((begin-program test1)
70      (assert-nargs-ee/locals 1 2)
71      (call 0 1 (1 2))
72      (add1 1 1)
73      (add1 1 1)
74      (return 1)
75      (end-program))))
76
77 (define test1b
78   (assemble-program
79    '((begin-program test1)
80      (assert-nargs-ee/locals 1 2)
81      (call 0 1 (1 2 3 4 5 6 7 8 9 10 11 12))
82      (add1 1 1)
83      (add1 1 1)
84      (return 1)
85      (end-program))))
86
87 (define test2
88   (assemble-program
89    '((begin-program test1)
90      (assert-nargs-ee/locals 1 2)
91      (call/values 0 1)
92      (add1 1 1)
93      (add1 1 1)
94      (return 1)
95      (end-program))))
96
97 (define test3
98   (assemble-program
99    '((begin-program test1)
100      (assert-nargs-ee/locals 1 2)
101      (tail-call 2 1)
102      (add1 1 1)
103      (add1 1 1)
104      (return 1)
105      (end-program))))
106
107 #;
108 (define test4
109   (assemble-program
110    '((begin-program test1)
111      (assert-nargs-ee/locals 1 2)
112      (subr-call 10 0)
113      (return 1)
114      (end-program))))
115
116 (define test5
117   (assemble-program
118    '((begin-program test1)
119      (assert-nargs-ee/locals 1 2)
120      (br-if-nargs-ne 2 out:)
121      (br-if-nargs-lt 2 out:)
122      (br-if-nargs-gt 2 out:)
123      (add1 1 1)
124      (label out:)
125      (assert-nargs-ee 3)
126      (assert-nargs-ge 4)
127      (reserve-locals 10)
128      (bind-rest 5)
129      (drop-values 3)
130      (return 1)
131      (end-program))))
132
133
134 (define test6
135   (assemble-program
136    '((begin-program test1)
137      (assert-nargs-ee/locals 1 2)
138      (label start)
139      (br out)
140      (br start)    
141      (br-if-true 0 0 start)
142      (br-if-true 0 1 start)
143      (br-if-true 0 0 out)
144      (br-if-true 0 1 out)
145      (br-if-null 0 0 start)
146      (br-if-null 0 1 start)
147      (br-if-null 0 0 out)
148      (br-if-null 0 1 out)
149      (br-if-nil  0 0 start)
150      (br-if-nil  0 1 start)
151      (br-if-nil  0 0 out)
152      (br-if-nil  0 1 out)
153      (label out)
154      (return 1)
155      (end-program))))
156                     
157 (define test7
158   (assemble-program
159    '((begin-program test7)
160      (assert-nargs-ee/locals 1 2)
161      (label start)
162      (br-if-pair 0 0 start)
163      (br-if-pair 0 1 start)
164      (br-if-pair 0 0 out)
165      (br-if-pair 0 1 out)
166
167      (br-if-struct 0 0 start)
168      (br-if-struct 0 1 start)
169      (br-if-struct 0 0 out)
170      (br-if-struct 0 1 out)
171
172      (br-if-char 0 0 start)
173      (br-if-char 0 1 start)
174      (br-if-char 0 0 out)
175      (br-if-char 0 1 out)
176
177      (br-if-tc7 0 0 3 start)
178      (br-if-tc7 0 1 3 start)
179      (br-if-tc7 0 0 3 out)
180      (br-if-tc7 0 1 3 out)
181
182      (label out)
183      (return 1)
184      (end-program))))
185
186 (define test8
187   (assemble-program
188    '((begin-program test7)
189      (assert-nargs-ee/locals 1 2)
190      (label start)
191      (br-if-eq 0 1 0 start)
192      (br-if-eq 0 1 1 start)
193      (br-if-eq 0 1 0 out)
194      (br-if-eq 0 1 1 out)
195
196      (br-if-eqv 0 2 0 start)
197      (br-if-eqv 0 2 1 start)
198      (br-if-eqv 0 2 0 out)
199      (br-if-eqv 0 2 1 out)
200
201      (br-if-equal 0 3 0 start)
202      (br-if-equal 0 3 1 start)
203      (br-if-equal 0 3 0 out)
204      (br-if-equal 0 3 1 out)
205
206      (label out)
207      (return 1)
208      (end-program))))
209
210 (define test9
211   (assemble-program
212    '((begin-program test7)
213      (assert-nargs-ee/locals 1 2)
214      (label start)
215      (br-if-= 0 1 start)
216      (br-if-= 0 1 out)
217
218      (br-if-< 0 1 start)
219      (br-if-< 0 1 out)
220
221      (br-if-<= 0 1 start)
222      (br-if-<= 0 1 out)
223
224      (br-if-> 0 1 start)
225      (br-if-> 0 1 out)
226
227      (br-if->= 0 1 start)
228      (br-if->= 0 1 out)
229
230      (label out)
231      (return 1)
232      (end-program))))
233
234 (define test10
235   (assemble-program
236    '((begin-program test7)
237      (assert-nargs-ee/locals 1 2)
238      (label start)
239      (mov 1 2)
240      (long-mov 1000000 1)
241      (box 3 4)
242      (empty-box 3)
243      (box-ref 3 4)
244      (box-set! 3 4)
245      (free-ref 3 4)
246      (label out)
247      (return 1)
248      (end-program))))
249
250 (define test11
251   (assemble-program
252    '((begin-program test7)
253      (assert-nargs-ee/locals 1 2)
254      (label start)     
255      (make-closure 1 out (1 2 3 4))
256      (fix-closure 1 (1 2 3 4))
257      (make-short-immediate 1 #f)
258      (make-long-immediate 1 #f)
259      (make-long-long-immediate 1 #f)
260      (static-ref 1 out)
261      ;(static-set! 1 out)   ;;TODO, this is not correctly imlemented
262      (link-procedure! 1 out)
263      (resolve 1 2 3)
264      (resolve-module 1 2 3)
265      (define 1 2)
266      (label out)
267      (return 1)
268      (end-program))))
269      
270 (define test12
271   (assemble-program
272    '((begin-program test7)
273      (assert-nargs-ee/locals 1 2)
274      (label start)   
275
276      (toplevel-ref 0 start out out)
277      (module-ref   0 start out out)
278      (wind 0 1)
279      (unwind)
280      (wind-fluids 4 (2 3 4))
281      (unwind-fluids)
282      (fluid-ref 7 8)
283      (fluid-set 8 7)
284      (label out)
285      (return 1)
286      (end-program))))
287
288 (define test13
289   (assemble-program
290    '((begin-program test7)
291      (assert-nargs-ee/locals 1 2)
292      (label start)   
293
294      (string-ref 1 2 3)
295      (string->number 1 2)
296      (string->symbol 1 2)
297      (symbol->keyword 1 2)
298
299      (cons 0 1 2)
300      (car 1 2)
301      (cdr 1 2)
302      (set-car! 1 2)
303      (set-cdr! 1 2)
304
305      (label out)
306      (return 1)
307      (end-program))))
308
309 (define test14
310   (assemble-program
311    '((begin-program test7)
312      (assert-nargs-ee/locals 1 2)
313      (label start)   
314
315      (add 1 2 3)
316      (add1 1 2)
317      (sub 1 2 3)
318      (sub1 1 2)
319
320      (mul 1 2 3)
321      (div 1 2 3)
322      (quo 1 2 3)
323      (rem 1 2 3)
324      (mod 1 2 3)
325      
326      (ash 1 2 3)
327
328      (logand 1 2 3)
329      (logior 1 2 3)
330      (logxor 1 2 3)
331
332      (label out)
333      (return 1)
334      (end-program))))
335
336 (define test15
337   (assemble-program
338    '((begin-program test7)
339      (assert-nargs-ee/locals 1 2)
340      (label start)   
341
342      (vector-length 1 2)
343      (vector-ref 1 2 3)
344      (constant-vector-ref 1 2 3)
345      (vector-set 1 2 3)
346
347      (struct-vtable 1 2)
348      (make-struct 1 2 (1 2 3))
349      (struct-ref 1 2 3)
350      (struct-set! 1 2 3)
351      
352      (class-of 1 2)
353      (slot-ref 1 2 3)
354      (slot-set! 1 2 3)
355
356      (label out)
357      (return 1)
358      (end-program))))
359
360 (define test16
361   (assemble-program
362    '((begin-program test7)
363      (assert-nargs-ee/locals 1 2)
364      (label start)   
365
366      (load-typed-array 1 2 3 out 4)
367      (make-array 1 2 3 4)
368      
369      (bv-u8-ref 1 2 3)
370      (bv-s8-ref 1 2 3)
371      (bv-u16-ref 1 2 3)
372      (bv-s16-ref 1 2 3)
373      (bv-u32-ref 1 2 3)
374      (bv-s32-ref 1 2 3)
375      (bv-u64-ref 1 2 3)
376      (bv-s64-ref 1 2 3)
377      (bv-f32-ref 1 2 3)
378      (bv-f64-ref 1 2 3)
379
380      (bv-u8-set! 1 2 3)
381      (bv-s8-set! 1 2 3)
382      (bv-u16-set! 1 2 3)
383      (bv-s16-set! 1 2 3)
384      (bv-u32-set! 1 2 3)
385      (bv-s32-set! 1 2 3)
386      (bv-u64-set! 1 2 3)
387      (bv-s64-set! 1 2 3)
388      (bv-f32-set! 1 2 3)
389      (bv-f64-set! 1 2 3)
390      
391      (label out)
392      (return 1)
393      (end-program))))
394
395 (define (test)
396   (jit test1   11)
397   (jit test1b  21)
398   (jit test2   8)
399   (jit test3   8)
400   (jit test5   16)
401   (jit test6   30)
402   (jit test7   36)
403   (jit test8   28)
404   (jit test9   24)
405   (jit test10  12)
406   (jit test11  30)
407   (jit test12  22)
408   (jit test13  13)
409   (jit test14  17)
410   (jit test15  19)
411   (jit test16  29))
412
413 (define x (make-u8vector 1000))
414 (define scan-bytevector
415   (assemble-program
416    '((begin-program test7)
417      (assert-nargs-ee/locals 2 3)
418      (make-short-immediate 2 0)
419      (make-short-immediate 3 0)
420
421      (label loop:)
422      (br-if-eq 1 3 0 out:)
423      (bv-u8-ref 4 0 1)
424      (add 2 2 4)
425      (sub1 1 1)
426      (br loop:)
427
428      (label out:)
429      (return 2))))
430
431 (define native-apply
432   (assemble-program
433    '((begin-program native-apply)
434      (assert-nargs-ee/locals 1 0)
435      (call 1 0 ())
436      (return 1)
437      (return 1)
438      (end-program))))
439
440
441 (define f1
442   (assemble-program
443    '((begin-program f1)
444      (assert-nargs-ee/locals 1 2)
445      (make-short-immediate 1 0)
446      (make-short-immediate 2 0)
447      (label loop:)     
448      (br-if-eq 0 2 0 out:)
449      (add 1 1 0)
450      (sub1 0 0)
451      (br loop:)
452      (label out:)
453      (return 1)
454      (end-program))))
455
456 (define test-br-narg
457   (assemble-program
458    '((begin-program test-br-narg)
459      (assert-nargs-ee/locals 2 0)
460      (br-if-nargs-ne 1 A:)
461      (return 0)
462      (label A:)
463      (br-if-nargs-lt 3 B:)
464      (return 0)
465      (label B:)
466      (br-if-nargs-gt 0 C:)
467      (return 0)
468      (label C:)
469      (return 1)
470      (end-program))))
471
472 (define (check-rsp i)
473   `(asm ,(inject-asm
474             (assemble ()
475              (inst mov reg1 (vm-rsp))             
476              (inst sub reg1 rbp)
477              (inst sal reg1 2)
478              (inst add reg1 2)
479              (inst mov (local-ref i) reg1)))))
480
481 (define test-bind-rest
482   (assemble-program
483    `((begin-program test-bind-rest)
484      (assert-nargs-ge 1)
485      (bind-rest 1)
486      (return 1)
487      (end-program))))
488
489 (define test-br-if
490   (assemble-program
491    `((begin-program test-bind-rest)
492      (assert-nargs-ee/locals 7 0)
493      (br-if-true 0 0 a:)
494      (return 0)
495      (label a:)
496      (br-if-true 1 1 b:)
497      (return 1)
498      (label b:)
499      (br-if-null 2 0 c:)
500      (return 2)
501      (label c:)
502      (br-if-null 3 1 d:)
503      (return 3)
504      (label d:)
505      (br-if-nil  4 0 e:)
506      (return 4)
507      (label e:)
508      (br-if-nil  5 1 f:)
509      (return 5)
510      (label f:)
511      (return 6)
512      (end-program))))
513
514 (define test-br-if2
515   (assemble-program
516    `((begin-program test-bind-rest)
517      (assert-nargs-ee/locals 12 0)
518      (br-if-pair 0 0 a:)
519      (return 0)
520      (label a:)
521      (br-if-pair 1 1 b:)
522      (return 1)
523      (label b:)
524      (br-if-struct 2 0 c:)
525      (return 2)
526      (label c:)
527      (br-if-struct 3 1 d:)
528      (return 3)
529      (label d:)
530      (br-if-char  4 0 e:)
531      (return 4)
532      (label e:)
533      (br-if-char  5 1 f:)
534      (return 5)
535      (label f:)
536      (br-if-tc7   6 0 ,tc7_vector g:)
537      (return 6)
538      (label g:)
539      (br-if-tc7   7 1 ,tc7_vector h:)
540      (return 7)
541      (label h:)
542      (br-if-eq    8 9 0 i:)
543      (return 9)
544      (label i:)
545      (br-if-eq    9 10 1 j:)
546      (return 10)
547      (label j:)
548      (return 11)
549      (end-program))))
550
551 (define binis '())
552
553 (define-syntax-rule (mk-bin nm op)
554   (begin
555     (define nm
556       (assemble-program
557        `((begin-program test-bind-rest)
558          (assert-nargs-ee/locals 2 0)
559          (op 0 0 1)
560          (return 0)
561          (end-program))))
562     (set! binis (cons (cons nm 5) binis))))
563
564 (define-syntax-rule (mk-uni nm op)
565   (begin
566     (define nm
567       (assemble-program
568        `((begin-program test-bind-rest)
569          (assert-nargs-ee/locals 1 0)
570          (op 0 0)
571          (return 0)
572          (end-program))))
573     (set! binis (cons (cons nm 5) binis))))
574
575 (define-syntax-rule (mk-set nm op)
576   (begin
577     (define nm
578       (assemble-program
579        `((begin-program test-bind-rest)
580          (assert-nargs-ee/locals 2 0)
581          (op 0 1)
582          (return 0)
583          (end-program))))
584     (set! binis (cons (cons nm 5) binis))))
585
586 (define-syntax-rule (mk-i-set nm op)
587   (begin
588     (define nm
589       (assemble-program
590        `((begin-program test-bind-rest)
591          (assert-nargs-ee/locals 3 0)
592          (op 0 1 2)
593          (return 0)
594          (end-program))))
595     (set! binis (cons (cons nm 5) binis))))
596
597 (define-syntax-rule (mk-ref nm op)
598   (begin
599     (define nm
600       (assemble-program
601        `((begin-program test-bind-rest)
602          (assert-nargs-ee/locals 2 0)
603          (op 0 0 1)
604          (return 0)
605          (end-program))))
606     (set! binis (cons (cons nm 5) binis))))
607
608 (define test-br-if-eqv
609   (assemble-program
610    `((begin-program test-bind-rest)
611      (assert-nargs-ee/locals 3 0)
612      (br-if-eqv 0 1 0 a:)
613      (return 0)
614      (label a:)
615      (return 2)
616      (end-program))))
617
618 (define test-br-if-not-eqv
619   (assemble-program
620    `((begin-program test-bind-rest)
621      (assert-nargs-ee/locals 3 0)
622      (br-if-eqv 0 1 1 a:)
623      (return 0)
624      (label a:)
625      (return 2)
626      (end-program))))
627
628 (define test-br-if-equal
629   (assemble-program
630    `((begin-program test-bind-rest)
631      (assert-nargs-ee/locals 3 0)
632      (br-if-equal 0 1 0 a:)
633      (return 0)
634      (label a:)
635      (return 2)
636      (end-program))))
637
638 (define test-br-if-not-equal
639   (assemble-program
640    `((begin-program test-bind-rest)
641      (assert-nargs-ee/locals 3 0)
642      (br-if-equal 0 1 1 a:)
643      (return 0)
644      (label a:)
645      (return 2)
646      (end-program))))
647
648
649 (define-syntax-rule (br_arithmetic br-if-=)
650   (begin
651     (define br-if-=
652       (assemble-program
653        `((begin-program test-bind-rest)
654          (assert-nargs-ee/locals 3 0)
655          (br-if-= 0 1 a:)
656          (return 0)
657          (label a:)
658          (return 2)
659          (end-program))))
660     (set! binis (cons (cons br-if-= 7) binis))))
661
662 (br_arithmetic br-if-=)
663 (br_arithmetic br-if-<)
664 (br_arithmetic br-if-<=)
665 (br_arithmetic br-if->)
666 (br_arithmetic br-if->=)
667
668 (define box
669   (assemble-program
670    `((begin-program test-bind-rest)
671      (assert-nargs-ee/locals 1 0)
672      (box 0 0)
673      (return 0)
674      (end-program))))
675
676 (define empty-box
677   (assemble-program
678    `((begin-program test-bind-rest)
679      (assert-nargs-ee/locals 0 1)
680      (empty-box 0)
681      (return 0)
682      (end-program))))
683
684 (define box-ref
685   (assemble-program
686    `((begin-program test-bind-rest)
687      (assert-nargs-ee/locals 1 0)
688      (box-ref 0 0)
689      (return 0)
690      (end-program))))
691
692 (define box-set!
693   (assemble-program
694    `((begin-program test-bind-rest)
695      (assert-nargs-ee/locals 2 0)
696      (box-set! 0 1)
697      (return 0)
698      (end-program))))
699
700 (define vtab (make-vtable "pwpw"))
701 (define s    (make-struct vtab 0 1 2))
702 (define s2   #(1))
703
704 (define const
705   (assemble-program
706    `((begin-program test-bind-rest)
707      (assert-nargs-ee/locals 0 2)
708      (load-constant 0 '(1 2))
709      (load-constant 1 a)
710      (cons 0 0 1)
711      (return 0)
712      (end-program))))
713
714 (define fluids
715   (assemble-program
716    `((begin-program test-bind-rest)
717      (assert-nargs-ee/locals 1 2)
718      (load-constant 1 '(1 2))
719      (fluid-ref 2 0)
720      (fluid-set 0 1)
721      (fluid-ref 0 0)
722      (cons 0 0 2)
723      (return 0)
724      (end-program))))  
725
726 (mk-uni s-length string-length)
727 (mk-uni s->num   string->number)
728 (mk-ref s-ref    string-ref)
729 (mk-uni sym->key symbol->keyword)
730
731 (mk-bin v-cons   cons)
732 (mk-uni v-car    car)
733 (mk-uni v-cdr    cdr)
734
735 (mk-set v-set-car set-car!)
736 (mk-set v-set-cdr set-cdr!)
737
738 (mk-bin add add)
739 (mk-uni add-1 add1)
740 (mk-bin sub sub)
741 (mk-uni sub-1 sub1)
742
743 (mk-bin v-mul mul)
744 (mk-bin v-div div)
745 (mk-bin v-quo quo)
746 (mk-bin v-rem rem)
747 (mk-bin v-mod mod)
748
749 (mk-bin v-ash ash)
750
751 (mk-bin v-logand logand)
752 (mk-bin v-logior logior)
753 (mk-bin v-logxor logxor)
754
755 (mk-uni   v-vector-length vector-length)
756 (mk-ref   v-vector-ref    vector-ref)
757 (mk-i-set v-vector-set!   vector-set)
758
759 (define const-v
760   (assemble-program
761    `((begin-program test-bind-rest)
762      (assert-nargs-ee/locals 1 0)
763      (constant-vector-ref 0 0 1)
764      (return 0)
765      (end-program))))  
766
767 (mk-uni   v-struct-vtable struct-vtable)
768 (mk-ref   v-struct-ref    struct-ref)
769 (mk-i-set v-struct-set!   struct-set!)
770
771 (mk-ref   v-slot-ref  slot-ref)
772 (mk-i-set v-slot-set! slot-set!)
773 (mk-uni   v-class-of  class-of)
774
775 (define test-closure
776   (assemble-program
777    `((begin-program test-closure)
778      (assert-nargs-ee/locals 2 1)
779      (make-closure 2 the-closure (0 1))
780      (fix-closure 2 (1 1))
781      (return 2)
782      (end-program)
783      (begin-program the-closure)
784      (assert-nargs-ee/locals 0 2)
785      (free-ref 0 0)
786      (free-ref 1 1)
787      (add 0 0 1)
788      (return 0)
789      (end-program))))
790
791   
792 (define mk-s
793   (assemble-program
794    `((begin-program test-bind-rest)
795      (assert-nargs-ee/locals 3 2)
796      (make-struct 0 0 (1 2)) 
797      (return 0)
798      (end-program))))  
799
800 (define const-long
801 (assemble-program
802    `((begin-program test-closure)
803      (assert-nargs-ee/locals 0 3)
804      (make-long-immediate  0 #x100000)
805      (make-long-long-immediate 1 #x100000000000)
806      (add 2 0 1)
807      (return 2)
808      (end-program))))
809
810 (define test-tail-call
811   (assemble-program
812    `((begin-program test-bind-rest)
813      (assert-nargs-ee/locals 3 0)
814      (add 0 0 1)
815      (tail-call 2 2)
816      (end-program))))
817   
818 (mk-bin v-resolve resolve)
819
820 (define v-resolve-module
821   (assemble-program
822    `((begin-program test-bind-rest)
823      (assert-nargs-ee/locals 1 2)
824      (resolve-module 1 0 0)
825      (resolve-module 2 0 1)
826      (cons 0 1 2)
827      (return 0)
828      (end-program))))
829   
830 (define test-alloc
831   (assemble-program
832    `((begin-program test-bind-rest)
833      (assert-nargs-ee/locals 1 2)
834      (return 2)
835      (end-program))))
836
837 (define (compile-tests)
838   (jit test-br-narg 13)
839   (jit test-bind-rest 5)
840   (jit test-br-if 22)
841   (jit test-br-if2 34)
842   (jit test-br-if-eqv 7)
843   (jit test-br-if-not-eqv 7)
844   (jit test-br-if-equal 7)
845   (jit test-br-if-not-equal 7)
846   (for-each (lambda (x) (jit (car x) (cdr x))) binis)
847   (jit box 5)
848   (jit empty-box 5)
849   (jit box-ref 5)
850   (jit box-set! 5)
851   (jit const 9)
852   (jit fluids 10)
853   (jit const-v 5)
854   (jit mk-s 8)
855   )
856
857
858 (define-syntax-rule (test x y)
859   (let ((a x) (b y))
860     (format #t "~%test > ~a == ~a~%------>~a got ~a~%" 'x 'y 
861             (if (equal? a b) 'OK '----FAIL----) a)))
862
863
864
865
866 (define (do-tests)
867   (test (test-br-narg 1 2) 
868         2)
869   (test (test-br-if 1 #f '() 2 #nil 4 'ok) 
870         'ok)
871   (test (test-bind-rest 1 2 3 4)
872         '(2 3 4))
873   (test (test-br-if2 (cons 1 2) 3 s 4 #\a 5 #(1 2) 6 s2 s2 7 'ok)
874         'ok)
875   )