source: project/chicken/trunk/tests/syntax-tests.scm @ 13582

Last change on this file since 13582 was 13582, checked in by felix winkelmann, 11 years ago

fix for syntax-rules bug reported by Jim Ursetto

File size: 5.5 KB
Line 
1;;;; mtest.scm - various macro tests
2
3
4(define-syntax t
5  (syntax-rules ()
6    ((_ r x)
7     (let ((tmp x))
8       (if (not (equal? r tmp))
9           (error "test failed" r tmp 'x)
10           (pp tmp))))))
11
12(define-syntax f
13  (syntax-rules ()
14    ((_ x)
15     (handle-exceptions ex (void)
16       x
17       (error "test returned, but should have failed" 'x) ))))
18
19(t 3 3)
20
21(f abc)
22
23(f (t 3 4))
24
25;; test syntax-rules
26
27(define-syntax test
28  (syntax-rules ()
29    ((_ x form)
30     (let ((tmp x))
31       (if (number? tmp)
32           form
33           (error "not a number" tmp))))))
34
35(t 100 (test 2 100))
36
37;; some basic contrived testing
38
39(define (fac n)
40  (let-syntax ((m1 (lambda (n r c) 
41                     (pp `(M1: ,n))
42                     (list (r 'sub1) (cadr n)))))
43    (define (sub1 . _)                  ; ref. transp.? (should not be used here)
44      (error "argh.") )
45    #;(print "fac: " n)           
46    (if (test n (zero? n))
47        1
48        (* n (fac (m1 n))))))
49
50(t 3628800 (fac 10))
51
52;; letrec-syntax
53
54(t 34
55(letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))
56                (bar (syntax-rules () ((_ x) (+ x 1)))))
57  (foo 33))
58)
59
60;; from r5rs:
61
62(t 45
63(let ((x 5))
64  (define foo (lambda (y) (bar x y)))
65  (define bar (lambda (a b) (+ (* a b) a)))
66  (foo (+ x 3)))
67)
68
69;; an error, according to r5rs - here it treats foo as defining a toplevel binding
70
71#;(let-syntax
72  ((foo (syntax-rules ()
73          ((foo (proc args ...) body ...)
74           (define proc
75             (lambda (args ...)
76               body ...))))))
77  (let ((x 3))
78    (foo (plus x y) (+ x y))
79    (define foo x)
80    (print (plus foo x))))
81
82(t 'now
83(let-syntax ((when (syntax-rules ()
84                     ((when test stmt1 stmt2 ...)
85                      (if test
86                          (begin stmt1
87                                 stmt2 ...))))))
88  (let ((if #t))
89    (when if (set! if 'now))
90    if))
91)
92
93(t 'outer
94(let ((x 'outer))
95  (let-syntax ((m (syntax-rules () ((m) x))))
96    (let ((x 'inner))
97      (m))))       
98)
99
100(t 7
101(letrec-syntax
102  ((my-or (syntax-rules ()
103            ((my-or) #f)
104            ((my-or e) e)
105            ((my-or e1 e2 ...)
106             (let ((temp e1))
107               (if temp
108                   temp
109                   (my-or e2 ...)))))))
110  (let ((x #f)
111        (y 7)
112        (temp 8)
113        (let odd?)
114        (if even?))
115    (my-or x
116           (let temp)
117           (if y)
118           y)))
119)
120
121(define-syntax kw
122  (syntax-rules (baz)
123    ((_ baz) "baz")
124    ((_ any) "no baz")))
125
126(t "baz" (kw baz))
127(t "no baz" (kw xxx))
128
129(let ((baz 100))
130  (t "no baz" (kw baz)))
131
132(t 'ok
133(let ((=> #f))
134  (cond (#t => 'ok)))
135)
136
137(t '(3 4)
138(let ((foo 3))
139  (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))
140    (let ((foo 4))
141      (bar foo))))
142)
143
144;;; alternative ellipsis test
145
146(define-syntax foo
147  (syntax-rules
148      ___ () 
149      ((_ vals ___) (list '... vals ___))))
150
151(t '(... 1 2 3)
152   (foo 1 2 3)
153)
154
155(define-syntax defalias
156  (syntax-rules ___ ()
157    ((_ new old)
158     (define-syntax new
159       (syntax-rules ()
160         ((_ args ...) (old args ...)))))))
161
162(defalias inc add1)
163
164(t 3 (inc 2))
165
166;;;
167
168(define-syntax usetmp
169  (syntax-rules ()
170    ((_ var) 
171     (list var))))
172
173(define-syntax withtmp
174  (syntax-rules ()
175    ((_ val exp)
176     (let ((tmp val))
177       (exp tmp)))))
178
179(t '(99)
180   (withtmp 99 usetmp)
181)
182
183(t 7
184(letrec-syntax
185    ((my-or (syntax-rules ()
186              ((my-or) #f)
187              ((my-or e) e)
188              ((my-or e1 e2 ...)
189               (let ((temp e1))
190                 (if temp
191                     temp
192                     (my-or e2 ...)))))))
193  (let ((x #f)
194        (y 7)
195        (temp 8)
196        (let odd?)
197        (if even?))
198    (my-or x
199           (let temp)
200           (if y)
201           y)))
202)
203
204(define-syntax foo
205  (syntax-rules ()
206    ((_ #(a ...)) (list a ...))))
207
208(t '(1 2 3)
209   (foo #(1 2 3))
210)
211
212
213(define-syntax loop
214  (lambda (x r c)
215    (let ((body (cdr x)))
216      `(,(r 'call/cc)
217        (,(r 'lambda) (exit)
218         (,(r 'let) ,(r 'f) () ,@body (,(r 'f))))))))
219
220(let ((n 10))
221  (loop
222   (print* n " ") 
223   (set! n (sub1 n))
224   (when (zero? n) (exit #f)))
225  (newline))
226
227(define-syntax while0
228  (syntax-rules ()
229    ((_ t b ...)
230     (loop (if (not t) (exit #f)) 
231           b ...))))
232
233(f (while0 #f (print "no.")))
234
235(define-syntax while
236  (lambda (x r c)
237    `(,(r 'loop) 
238      (,(r 'if) (,(r 'not) ,(cadr x)) (exit #f))
239      ,@(cddr x))))
240
241(let ((n 10))
242  (while (not (zero? n))
243         (print* n " ")
244         (set! n (- n 1)) )
245  (newline))
246
247;;; found by Jim Ursetto
248
249(let ((lambda 0)) (define (foo) 1) (foo))
250
251
252;;; define-macro implementation (only usable in a module-free environment)
253
254(define-syntax define-macro
255  (syntax-rules ()
256    ((_ (name . llist) body ...)
257     (define-syntax name
258       (lambda (x r c)
259         (apply (lambda llist body ...) (strip-syntax (cdr x))))))))
260
261(define-macro (loop . body)
262  (let ((loop (gensym)))
263    `(call/cc
264      (lambda (exit)
265        (let ,loop () ,@body (,loop))))))
266
267(let ((i 1))
268  (loop (when (> i 10) (exit #f))
269        (print* i " ")
270        (set! i (add1 i))))
271(newline)
272
273
274;;;; exported macro would override original name (fixed in rev. 13351)
275
276(module xfoo (xbaz xbar)
277  (import scheme)
278  (define-syntax xbar
279    (syntax-rules ()
280      ((_ 1) (xbaz))
281      ((_) 'xbar)))
282  (define-syntax xbaz
283    (syntax-rules ()
284      ((_ 1) (xbar))
285      ((_) 'xbazz))))
286
287(import xfoo)
288(assert (eq? 'xbar (xbaz 1)))
289(assert (eq? 'xbazz (xbar 1)))
290(assert (eq? 'xbar (xbar)))
291
292
293;;;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
294
295(define-syntax foo
296  (syntax-rules ()
297    ((_ (a b) ...)
298     (list '(a b) ...))
299    ((_ a ...)
300     (list '(a) ...))))
301
302(assert (equal? (foo (1 2) (3 4) (5 6)) '((1 2) (3 4) (5 6))))
303(assert (equal? (foo (1 2) (3) (5 6)) '(((1 2)) ((3)) ((5 6))))) ; failed
304(assert (equal? (foo 1) '((1))))
Note: See TracBrowser for help on using the repository browser.