source: project/release/5/procedural-macros/tags/2.0/tests/run.scm @ 38044

Last change on this file since 38044 was 38044, checked in by juergen, 2 months ago

procedural-macros 2.0 simplified and streamlined

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