source: project/chicken/branches/scrutiny/tests/syntax-tests.scm @ 14827

Last change on this file since 14827 was 14827, checked in by felix winkelmann, 10 years ago

merged trunk changes until 14826 into scrutiny branch

File size: 6.3 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  (er-macro-transformer
215   (lambda (x r c)
216     (let ((body (cdr x)))
217       `(,(r 'call/cc)
218         (,(r 'lambda) (exit)
219          (,(r 'let) ,(r 'f) () ,@body (,(r 'f)))))))))
220
221(let ((n 10))
222  (loop
223   (print* n " ") 
224   (set! n (sub1 n))
225   (when (zero? n) (exit #f)))
226  (newline))
227
228(define-syntax while0
229  (syntax-rules ()
230    ((_ t b ...)
231     (loop (if (not t) (exit #f)) 
232           b ...))))
233
234(f (while0 #f (print "no.")))
235
236(define-syntax while
237  (er-macro-transformer
238   (lambda (x r c)
239     `(,(r 'loop) 
240       (,(r 'if) (,(r 'not) ,(cadr x)) (exit #f))
241       ,@(cddr x)))))
242
243(let ((n 10))
244  (while (not (zero? n))
245         (print* n " ")
246         (set! n (- n 1)) )
247  (newline))
248
249;;; found by Jim Ursetto
250
251(let ((lambda 0)) (define (foo) 1) (foo))
252
253
254;;; define-macro implementation (only usable in a module-free environment)
255
256(define-syntax define-macro
257  (syntax-rules ()
258    ((_ (name . llist) body ...)
259     (define-syntax name
260       (lambda (x r c)
261         (apply (lambda llist body ...) (strip-syntax (cdr x))))))))
262
263(define-macro (loop . body)
264  (let ((loop (gensym)))
265    `(call/cc
266      (lambda (exit)
267        (let ,loop () ,@body (,loop))))))
268
269(let ((i 1))
270  (loop (when (> i 10) (exit #f))
271        (print* i " ")
272        (set! i (add1 i))))
273(newline)
274
275
276;;;; exported macro would override original name (fixed in rev. 13351)
277
278(module xfoo (xbaz xbar)
279  (import scheme)
280  (define-syntax xbar
281    (syntax-rules ()
282      ((_ 1) (xbaz))
283      ((_) 'xbar)))
284  (define-syntax xbaz
285    (syntax-rules ()
286      ((_ 1) (xbar))
287      ((_) 'xbazz))))
288
289(import xfoo)
290(assert (eq? 'xbar (xbaz 1)))
291(assert (eq? 'xbazz (xbar 1)))
292(assert (eq? 'xbar (xbar)))
293
294
295;;;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
296
297(define-syntax foo
298  (syntax-rules ()
299    ((_ (a b) ...)
300     (list '(a b) ...))
301    ((_ a ...)
302     (list '(a) ...))))
303
304(assert (equal? (foo (1 2) (3 4) (5 6)) '((1 2) (3 4) (5 6))))
305(assert (equal? (foo (1 2) (3) (5 6)) '(((1 2)) ((3)) ((5 6))))) ; failed
306(assert (equal? (foo 1) '((1))))
307
308
309;;; incorrect lookup for keyword variables in DSSSL llists
310
311(module broken-keyword-var ()
312  (import scheme chicken)
313  ((lambda (#!key string) (assert (not string))))) ; refered to R5RS `string'
314
315
316;;; compiler didn't resolve expansion into local variable
317;;; (reported by Alex Shinn, #15)
318
319(module unresolve-local (foo)
320  (import scheme)
321  (define (foo)
322    (let ((qux 3))
323      (let-syntax ((bar (syntax-rules () ((bar) qux))))
324        (bar))))
325
326  (display (foo))
327  (newline)
328)
329
330
331;;; incorrect expansion when assigning to something marked '##core#primitive (rev. 14613)
332
333(define x 99)
334
335(module primitive-assign ()
336  (import scheme chicken)
337  (let ((x 100)) (set! x 20) (assert (= x 20)))
338  (set! setter 123))
339
340(assert (= x 99))
341(assert (= 123 setter))
342
Note: See TracBrowser for help on using the repository browser.