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

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

added testcase

File size: 5.1 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)))
Note: See TracBrowser for help on using the repository browser.