source: project/release/5/procedural-macros/trunk/tests/run.scm @ 37432

Last change on this file since 37432 was 37432, checked in by juergen, 12 months ago

procedural-macros 1.0.1

File size: 8.2 KB
Line 
1(import scheme (chicken base)
2        procedural-macros
3        simple-tests)
4(import-for-syntax (only procedural-macros
5                         with-mapped-symbols
6                         macro-rules
7                         once-only)
8                   (only (chicken base) list-of?)
9                   (only bindings bind bind-case)
10                   )
11
12(define Counter
13  (let ((n 0))
14    (lambda ()
15      (set! n (add1 n))
16      n)))
17
18(define-er-macro (Square form % compare?)
19  (let ((x (cadr form)))
20    (once-only (x)
21      `(* ,x ,x))))
22
23(define-er-macro-transformer (Swap! form rename compare?)
24  (let ((x (cadr form)) (y (caddr form)))
25    (with-mapped-symbols rename % (%tmp %let %set!)
26      `(,%let ((,%tmp ,x))
27         (,%set! ,x ,y)
28         (,%set! ,y ,%tmp)))))
29
30(define-er-macro (Nif form % compare?)
31  (bind (_ xpr pos zer neg)
32    form
33    `(,%let ((,%result ,xpr))
34            (,%cond
35              ((,%positive? ,%result) ,pos)
36              ((,%negative? ,%result) ,neg)
37              (,%else ,zer)))))
38
39(define-ir-macro (Vif form % compare?)
40  (bind-case form
41    ((_ test (key xpr . xprs))
42     (cond
43       ((compare? key %then)
44        `(if ,test (begin ,xpr ,@xprs)))
45       ((compare? key %else)
46        `(if ,(not test) (begin ,xpr ,@xprs)))
47       (else
48         `(error 'Vif "syntax-error"))))
49    ((_ test (key1 xpr . xprs) (key2 ypr . yprs))
50     (cond
51       ((and (compare? key1 %then)
52             (compare? key2 %else))
53       `(if ,test
54          (begin ,xpr ,@xprs)
55          (begin ,ypr ,@yprs)))
56       ((and (compare? key1 %else)
57             (compare? key2 %then))
58       `(if ,test
59          (begin ,ypr ,@yprs)
60          (begin ,xpr ,@xprs)))
61       (else
62         `(error 'Vif "syntax-error"))))
63    ))
64
65(define-ir-macro (Alambda form % compare?)
66  (bind (_ args xpr . xprs) form
67    `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
68       ,%self)))
69
70(define-test (basic-macros?)
71  (= (Square (Counter)) 1)
72  (= (Square (Counter)) 4)
73  (= (Square (Counter)) 9)
74
75  (equal? (let ((x 'x) (y 'y))
76            (Swap! x y)
77            (list x y))
78          '(y x))
79
80  (eq? (Nif 5 'pos 'zer 'neg) 'pos)
81
82  ;;; verbose if
83  (eq? (Vif (positive? 5) (then 'pos)) 'pos)
84
85  (equal?
86    (map (Alambda (n)
87           (if (zero? n)
88             1
89             (* n (self (- n 1)))))
90         '(1 2 3 4 5))
91    '(1 2 6 24 120))
92  )
93
94(define-macro (swap! x y)
95  `(let ((tmp ,x)) (set! ,x ,y) (set! ,y tmp)))
96
97(define-macro (nif xpr pos zer neg)
98  `(cond
99     ((positive? ,xpr) ,pos)
100     ((negative? ,xpr) ,neg)
101     (else ,zer)))
102
103(define-macro (freeze xpr)
104  `(lambda () ,xpr))
105
106(define-syntax foo
107  (macro-rules ()
108    ((_ "foo" x) x)
109    ((_ #f x) `(list 'false))
110    ((_ #f x) 'false)
111    ((_ a b) (where (a string?))
112             `(list ,a ,b))
113    ((_ a b) (where (a odd?))
114             `(list ,a ,b))
115    ((_ a b) a)))
116
117(define-macro (bar #() x)
118  (where (x integer?))
119  x)
120
121(define-macro (qux  #f)
122  #t)
123
124(define-macro (in? what equ? . choices)
125  (let ((insym 'in))
126    `(let ((,insym ,what))
127       (or ,@(map (lambda (choice) `(,equ? ,insym ,choice))
128                  choices)))))
129
130(define-syntax vif
131  (macro-rules (then else)
132    ((_ test (then . xprs))
133     `(if ,test
134        (begin ,@xprs)))
135    ((_ test (else . xprs))
136     `(if ,(not test)
137        (begin ,@xprs)))
138    ((_ test (then . xprs) (else . yprs))
139     `(if ,test
140        (begin  ,@xprs)
141        (begin  ,@yprs)))))
142
143(define (oux)
144  (vif #t (then 'true)))
145
146(define (pux)
147  (vif #f (else 'false)))
148
149(define-syntax my-cond
150  (macro-rules (else =>)
151    ((_ (else xpr . xprs))
152     `(begin ,xpr ,@xprs))
153    ((_ (test => xpr))
154     `(let ((tmp ,test))
155        (if tmp (,xpr tmp))))
156    ((_ (test => xpr) . clauses)
157     `(let ((tmp ,test))
158        (if tmp
159          (,xpr tmp)
160          (my-cond ,@clauses))))
161    ((_ (test))
162     `(if #f #f))
163    ((_ (test) . clauses)
164     `(let ((tmp ,test))
165        (if tmp
166          tmp
167          (my-cond ,@clauses))))
168    ((_ (test xpr . xprs))
169     `(if ,test (begin ,xpr ,@xprs)))
170    ((_ (test xpr . xprs) . clauses)
171     `(if ,test
172        (begin ,xpr ,@xprs)
173        (my-cond ,@clauses)))
174    ))
175
176(define-macro (my-letrec pairs . body)
177  (where (pairs (list-of? pair?)))
178  (let ((vars (map car pairs))
179        (vals (map cadr pairs))
180        (aux (map (lambda (x) (gensym)) pairs)))
181    `(let ,(map (lambda (var) `(,var #f)) vars)
182       (let ,(map (lambda (a v) `(,a ,v)) aux vals)
183         ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
184         ,@body))))
185
186(define-syntax add
187  (macro-rules () ((_ x y)
188                   (where (x string?) (y string?))
189                   `(string-append ,x ,y))
190    (( _ x y)
191     (where (x integer?) (y integer?))
192     `(+ ,x ,y))))
193
194(define-syntax alambda
195  (macro-rules self ()
196    ((_ args xpr . xprs)
197     `(letrec ((,self (lambda ,args ,xpr ,@xprs)))
198        ,self))))
199
200(define-syntax aif
201  (macro-rules it ()
202    ((_ test consequent)
203     `(let ((,it ,test))
204        (if ,it ,consequent)))
205    ((_ test consequent alternative)
206     `(let ((,it ,test))
207        (if ,it ,consequent ,alternative)))))
208
209(define (mist x)
210  (aif ((alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) x) it))
211
212(define counter ; used for side-effects
213  (let ((state 0))
214    (lambda ()
215      (set! state (+ state 1))
216      state)))
217
218(define-macro (square x) ; wrong without once-only
219  (once-only (x)
220    `(* ,x ,x)))
221
222(define-syntax add2
223  (let ((id (lambda (n) n)))
224    (macro-rules ()
225      ((_ x)
226       `(+ ,(id x) 2))
227      ((_ x y)
228       `(+ ,(id x) ,(id y) 2))
229      )))
230
231(define-macro (for (var start end) . body)
232  (once-only (start end)
233    `(do ((,var ,start (add1 ,var)))
234       ((= ,var ,end))
235       ,@body)))
236
237(define-test (procedural-macros?)
238  (equal? (let ((x 'x) (y 'y))
239            (swap! x y)
240            (list x y))
241          '(y x))
242
243  (eq? (nif 2 'positive 'zero 'negative) 'positive)
244
245  (= ((freeze 5)) 5)
246
247  (equal? (let ((x 'x) (y 'y)) (swap! x y) (list x y))
248          '(y x))
249
250  "LITERALS"
251  (= (foo "foo" 1) 1)
252  (equal? (foo "bar" 2) '("bar" 2))
253  (equal? (foo #f 'blabla) '(false))
254  (equal? (foo 1 2) '(1 2))
255  (= (foo 2 3) 2)
256
257  (= (bar #() 5) 5)
258
259  (qux #f)
260
261  "IN?"
262  (in? 2 = 1 2 3)
263  (not (in? 5 = 1 2 3))
264
265  "VERBOSE IFS"
266  (eq? (oux) 'true)
267  (eq? (pux) 'false)
268
269  "LOW-LEVEL COND"
270  (my-cond ((> 3 2)))
271  (eq? (my-cond ((> 3 2) 'greater) ((< 3 2) 'less))
272       'greater)
273  (eq? (my-cond
274         ((> 3 3) 'greater)
275         ((< 3 3) 'less)
276         (else 'equal))
277       'equal)
278  (= (my-cond ((assv 'b `((a 1) (b 2) (C 3))) => cadr)
279              (else #f))
280     2)
281  (not (my-cond ((assv 'x `((a 1) (b 2) (C 3))) => cadr)
282                (else #f)))
283
284  "LETREC"
285  (equal?
286    (my-letrec ((o? (lambda (m) (if (zero? m) #f (e? (- m 1)))))
287                (e? (lambda (n) (if (zero? n) #t (o? (- n 1))))))
288               (list (o? 95) (e? 95)))
289    '(#t #f))
290
291  "GENERIC ADD"
292  (= (add 1 2) 3)
293  (string=? (add "x" "y") "xy")
294
295  "ANAPHORIC MACROS"
296  (equal? (map (alambda (n) (if (zero? n) 1 (* n (self (- n 1))))) '(1 2 3 4 5))
297          '(1 2 6 24 120))
298
299  (= (mist 5) 120)
300
301  "ONCE-ONLY"
302  (= (square (counter)) 1)
303  (= (square (counter)) 4)
304  (= (square (counter)) 9)
305  (let ((lst '()))
306    (for (x 0 (counter)) (set! lst (cons x lst)))
307    (equal? lst '(3 2 1 0)))
308
309  "LOCAL VARIABLES AVAILABLE IN EACH RULE"
310  (= (add2 5) 7)
311  (= (add2 5 7) 14)
312
313
314  "LET AND LETREC"
315  (= (macro-letrec (
316       ((sec lst) `(car (res ,lst)))
317       ((res lst) `(cdr ,lst))
318       )
319       (sec '(1 2 3)))
320     2)
321  (= (macro-let (
322       ((fir lst) (where (lst list?)) `(car ,lst))
323       ((res lst) (where (lst list?)) `(cdr ,lst))
324       )
325       (fir (res '(1 2 3))))
326     2)
327  (equal?
328    (macro-letrec (((swap1 x y)
329                    `(swap2 ,x ,y))
330                   ((swap2 x y)
331                    (where (x symbol?) (y symbol?))
332                    `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
333      (let ((x 'x) (y 'y))
334        (swap1 x y)
335        (swap2 x y)
336        (list x y)))
337    '(x y))
338  (equal?
339    (macro-let (((swap1 x y)
340                 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp)))
341                ((swap2 x y)
342                 `(let ((tmp ,y)) (set! ,y ,x) (set! ,x tmp))))
343      (let ((x 'x) (y 'y))
344        (swap1 x y)
345        (swap2 x y)
346        (list x y)))
347    '(x y))
348  )
349
350(compound-test (procedural-macros)
351  (basic-macros?)
352  (procedural-macros?)
353) ; compound test
Note: See TracBrowser for help on using the repository browser.