source: project/release/4/basic-macros/tags/1.2/tests/run.scm @ 34873

Last change on this file since 34873 was 34873, checked in by juergen, 4 years ago

basic-macros 1.2 with procedural bind-case to improve error message

File size: 6.3 KB
Line 
1(require-library simple-tests basic-macros)
2(begin-for-syntax (require-library basic-macros simple-tests))
3(import scheme chicken basic-macro-helpers basic-macros simple-tests)
4(import-for-syntax (only basic-macro-helpers pseudo-ref pseudo-tail))
5
6;(print "IIIIIIIIII ir-macro alambda")
7;(pe '
8;  (define-ir-macro (alambda form % compare?)
9;    (bind (_ args xpr . xprs) form
10;      `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
11;         ,%self)))
12;  )
13;
14;(print "ALAMBDA")
15;(pe '
16;  (alambda (n)
17;    (if (zero? n)
18;      1
19;      (* n (self (- n 1)))))
20;  )
21;
22;(print "EEEEEEEEEE er-macro nif")
23;(pe '
24;  (define-er-macro (nif form % compare?)
25;    (bind (_ xpr pos zero neg) form
26;      `(,%let ((,%result ,xpr))
27;              (,%cond
28;                ((,%positive? ,%result) 'pos)
29;                ((,%negative? ,%result) 'neg)
30;                (,%else 'zero)))))
31;  )
32;
33;(print "NIF")
34;(pe '(nif xpr pos zero neg))
35;
36(define-test (pseudolists)
37  (check
38    (pseudo-list? "x")
39    (pseudo-null? 5)
40    (equal? (pseudo-list #f 1 2 3 4)
41            '(1 2 3 4 . #f))
42    (not (pseudo-sentinel
43           (pseudo-list #f 1 2 3 4)))
44    (= (pseudo-tail 1 0) 1)
45    (equal? (pseudo-head 1 0) '())
46    (equal? (pseudo-head '(0 . 1) 0) '())
47    (equal? (pseudo-head '(0 . 1) 1) '(0))
48    (not (condition-case (pseudo-ref 1 0)
49           ((exn) #f)))
50    (equal? (pseudo-tail '(0 1 2 3 . 4) 1)
51            '(1 2 3 . 4))
52    (= (pseudo-ref '(0 1 2 3 . 4) 1) 1)
53    (= (pseudo-length '(0 1 2 3 . 4)) 4)
54    (equal? (pseudo-flatten '(0 1 . 2)) '(0 1 2))
55    (equal? (pseudo-flatten '(0 (1 2))) '(0 1 2))
56    (equal? (pseudo-flatten '(0 (1 (2 . 3)))) '(0 1 2 3))
57    (equal? (pseudo-flatten '(0 (1 (2 . 3) 4))) '(0 1 2 3 4))
58    ))
59
60
61(define-test (other-helpers)
62  (check
63    (sym-prepends? '% '%foo)
64    (eq? (sym-tail '% '%foo) 'foo)
65    (equal? (adjoin 1 '(0 1 2 3)) '(0 1 2 3))
66    (equal? (adjoin 1 '()) '(1))
67    (equal? (remove-duplicates '(0 1 2 1 3 2)) '(0 1 2 3))
68    (equal? (filter odd? '(0 1 2 3 4)) '(1 3))
69    ))
70
71
72(define-test (bindings)
73  (check
74    (= (bind x 1 x) 1)
75    (equal? (bind (x . y) (cons 1 2) (list x y)) '(1 2))
76    (equal? (bind (x (y (z . w))) '(1 (2 (3 . 4))) (list x y z w))
77            '(1 2 3 4))
78    (equal? (bind (x (y (z . w))) '(1 (2 (3 4 5))) (list x y z w))
79            '(1 2 3 (4 5)))
80    (= (bind (x . #f) (cons 1 #f) x) 1)
81    (equal? (bind (x "y" z) '(1 "y" 2) (list x z)) '(1 2))
82    (eq? (condition-case
83           (bind (x . _) (list 1 2 3 4) _)
84             ((exn) 'wildcard-not-a-variable))
85         'wildcard-not-a-variable)
86    (eq? (condition-case
87           (bind (x . #f) (cons 1 #t) x)
88             ((exn) 'literals-dont-match))
89         'literals-dont-match)
90    (eq? (condition-case
91           (bind (x "y" z) '(1 "q" 2) (list x z))
92             ((exn) 'literals-dont-match))
93         'literals-dont-match)
94    (equal? (bind-case '(2 2)
95              ((a b) (where (a even?) (b odd?)) (print 'even-odd a b))
96              ((a b) (where (a odd?) (b even?)) (print 'odd-even a b))
97              ((a b) (list a b)))
98            '(2 2))
99    (equal? (bind-case '(1 (2 3))
100              ((x y) (where (y number?)) (list x y))
101              ((x (y . z)) (list x y z))
102              ((x (y z)) (list x y z)))
103            '(1 2 (3)))
104    (equal? (bind-case '(1 (2 3))
105              ((x y) (list x y))
106              ((x (y . z)) (list x y z))
107              ((x (y z)) (list x y z)))
108            '(1 (2 3)))
109    (equal? (bind-case '(1 (2 . 3))
110              ((x y) (list x y))
111              ((x (y . z)) (list x y z))
112              ((x (y z)) (list x y z)))
113            '(1 (2 . 3)))
114    (define (my-map fn lst)
115      (let loop ((lst lst) (result '()))
116        (bind-case lst
117          (() (reverse result))
118          ((x . xs)
119           (loop xs (cons (fn x) result))))))
120    (equal? (my-map add1 '(0 1 2 3 4))
121            '(1 2 3 4 5))
122    ))
123 
124(use-for-syntax (only basic-macros
125                      bind
126                      bind-case
127                      once-only
128                      with-mapped-symbols)) ;;;;;
129
130(define-test (basic-macros)
131  (check
132    (define counter
133      (let ((n 0))
134        (lambda ()
135          (set! n (add1 n))
136          n)))
137    (define-er-macro (square form % compare?)
138      (let ((x (cadr form)))
139        (once-only (x)
140          `(* ,x ,x))))
141    (= (square (counter)) 1)
142    (= (square (counter)) 4)
143    (= (square (counter)) 9)
144
145    (define-er-macro-transformer (swap! form rename compare?)
146      (let ((x (cadr form)) (y (caddr form)))
147        (with-mapped-symbols rename % (%tmp %let %set!)
148          `(,%let ((,%tmp ,x))
149             (,%set! ,x ,y)
150             (,%set! ,y ,%tmp)))))
151    (equal? (let ((x 'x) (y 'y))
152              (swap! x y)
153              (list x y))
154            '(y x))
155
156    (define-er-macro (nif form % compare?)
157      (bind (_ xpr pos zer neg)
158        form
159        `(,%let ((,%result ,xpr))
160                (,%cond
161                  ((,%positive? ,%result) ,pos)
162                  ((,%negative? ,%result) ,neg)
163                  (,%else ,zer)))))
164    (eq? (nif 5 'pos 'zer 'neg) 'pos)
165
166    ;;; verbose if
167    (define-ir-macro (vif form % compare?)
168      (bind-case form
169        ((_ test (key xpr . xprs))
170         (cond
171           ((compare? key %then)
172            `(if ,test (begin ,xpr ,@xprs)))
173           ((compare? key %else)
174            `(if ,(not test) (begin ,xpr ,@xprs)))
175           (else
176             `(error 'vif "syntax-error"))))
177        ((_ test (key1 xpr . xprs) (key2 ypr . yprs))
178         (cond
179           ((and (compare? key1 %then)
180                 (compare? key2 %else))
181           `(if ,test
182              (begin ,xpr ,@xprs)
183              (begin ,ypr ,@yprs)))
184           ((and (compare? key1 %else)
185                 (compare? key2 %then))
186           `(if ,test
187              (begin ,ypr ,@yprs)
188              (begin ,xpr ,@xprs)))
189           (else
190             `(error 'vif "syntax-error"))))
191        ))
192    (eq? (vif (positive? 5) (then 'pos)) 'pos)
193
194    (define-ir-macro (alambda form % compare?)
195      (bind (_ args xpr . xprs) form
196        `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
197           ,%self)))
198    (equal?
199      (map (alambda (n)
200             (if (zero? n)
201               1
202               (* n (self (- n 1)))))
203           '(1 2 3 4 5))
204      '(1 2 6 24 120))
205    ))
206
207(compound-test (MACROS)
208  (pseudolists)
209  (other-helpers)
210  ;(bindings)
211  (basic-macros)
212  )
213
Note: See TracBrowser for help on using the repository browser.