source: project/release/4/r7rs/trunk/tests/run.scm @ 29432

Last change on this file since 29432 was 29432, checked in by sjamaan, 7 years ago

r7rs: mem*, ass*, list-copy; this completes 6.4: pairs and lists

File size: 23.1 KB
Line 
1(use r7rs test)
2
3;; XXX: This seems to be necessary in order to get the syntax-rules
4;; from r7rs rather than the built-in CHICKEN one.  I'm not sure if
5;; that's correct or not...
6(import-for-syntax r7rs)
7
8(define (read-from-string s)
9  (with-input-from-string s read))
10
11(test-begin "r7rs tests")
12
13(test-group "6.3: booleans"
14  (test-group "long boolean literals"
15    (test #t (read-from-string "#t"))
16    (test #f (read-from-string "#f"))
17    (test #t (read-from-string "#true"))
18    (test #f (read-from-string "#false"))
19    (test-error (read-from-string "#faux")))
20
21  (test-group "boolean=?"
22    (test #t (boolean=? #t #t))
23    (test #t (boolean=? #t #t #t #t))
24    (test #t (boolean=? #f #f))
25    (test #t (boolean=? #f #f #f #f))
26    (test #f (boolean=? #f #t))
27    (test #f (boolean=? #f #t #t #t))
28    (test #f (boolean=? #f #f #t #t))
29    (test #f (boolean=? #f #f #f #t))
30    (test #f (boolean=? #t #f #f #f))
31    (test #f (boolean=? #t #f #f #t))
32    (test #f (boolean=? #t #t #f #t))
33    (test #f (boolean=? #f #f #f #t))
34    (test #f (boolean=? #f #t #f #f))
35    (test-error (boolean=? #f))
36    (test-error (boolean=? #f 1))
37    (test-error "no shortcutting" (boolean=? #f #t 2))))
38
39(test-group "6.4: pairs and lists"
40  (test-group "pair?"
41    (test #t (pair? '(a . b)))
42    (test #t (pair? '(a b c)))
43    (test #f (pair? '()))
44    (test #f (pair? '#(a b)))
45    (test #f (pair? #f))
46    (test #f (pair? #t))
47    (test #f (pair? "some string"))
48    (test #f (pair? 123)))
49
50  (test-group "cons"
51    (test '(a) (cons 'a '()))
52    (test '((a) b c d) (cons '(a) '(b c d)))
53    (test '("a" b c) (cons "a" '(b c)))
54    (test '(a . 3) (cons 'a 3))
55    (test '((a b) . c) (cons '(a b) 'c)))
56
57  (test-group "car"
58    (test 'a (car '(a b c)))
59    (test '(a) (car '((a) b c d)))
60    (test 1 (car '(1 . 2)))
61    (test-error (car '()))
62    (test-error (car '#(1 2 3)))
63    (test-error (car "not a pair")))
64
65  (test-group "cdr"
66    (test '(b c d) (cdr '((a) b c d)))
67    (test 2 (cdr '(1 . 2)))
68    (test-error (cdr '()))
69    (test-error (cdr '#(1 2 3)))
70    (test-error (cdr "not a pair")))
71
72  (test-group "set-car!"
73    (define (f) (list 'not-a-constant-list))
74    (define (g) '(constant-list))
75    ;; Examples from the text are very incomplete and strange
76    (let ((res (f)))
77      (set-car! res 2)
78      (test 2 (car res))
79      (set-car! (f) 3)
80      (test 'not-a-constant-list (car (f))))
81    ;; XXX Should this *raise* an error?  R5RS also says this it "is an error"
82    #;(test-error (set-car! (g) 3))
83    (test-error (set-car! 'x 'y)))
84
85  (test-group "set-cdr!"
86    (define (f) (list 'not-a-constant-list))
87    (define (g) '(constant-list))
88    ;; Examples from the text are very incomplete and strange
89    (let ((res (f)))
90      (set-cdr! res 2)
91      (test 2 (cdr res))
92      (set-cdr! (f) 3)
93      (test '() (cdr (f))))
94    ;; XXX Should this *raise* an error?  R5RS also says this it "is an error"
95    #;(test-error (set-cdr! (g) 3))
96    (test-error (set-cdr! 'x 'y)))
97
98  (test-group "c..r (base)"
99    (test 'x (caar '((x) y)))
100    (test-error (caar '(x y)))
101    (test 'y (cadr '((x) y)))
102    (test-error (cadr '(x)))
103    (test '() (cdar '((x) y)))
104    (test-error (cdar '(x)))
105    (test '() (cddr '((x) y)))
106    (test-error (cddr '(x))))
107
108  ;; TODO: c..r (cxr)
109 
110  (test-group "null?"
111    (test #t (null? '()))
112    (test #t (null? (list)))
113    (test #f (null? '(a)))
114    (test #f (null? 'a))
115    (test #f (null? '#()))
116    (test #f (null? "foo")))
117
118  (test-group "list?"
119    (test #t (list? '(a b c)))
120    (test #t (list? (list 'a 'b 'c)))
121    (test #t (list? '()))
122    (test #f (list? '(a . b)))
123    (let ((x (list 'a)))
124      (set-cdr! x x)
125      (test #f (list? x)))
126    (test #f (list? 'a))
127    (test #f (list? '#()))
128    (test #f (list? "foo")))
129
130  (test-group "make-list"
131    (test-error (make-list))
132    (test '() (make-list 0))
133    (test '(#f) (make-list 1))          ; Unspecified
134   
135    (test '(#f) (make-list 1 #f))
136    (test-error (make-list 1 2 3))
137    (test '(3 3) (make-list 2 3))
138    (test '() (make-list 0 3))
139    (test-error (make-list -1 3))
140    (test-error (make-list #f 3)))
141
142  (test-group "list"
143    (test '(a 7 c) (list 'a (+ 3 4) 'c))
144    (test '() (list))
145    (test '(#f) (list #f))
146    (test '(a b c) (list 'a 'b 'c)))
147
148  (test-group "length"
149    (test 3 (length '(a b c)))
150    (test 3 (length '(a (b) (c d e))))
151    (test 0 (length '()))
152
153    (test-error (length '(x . y)))
154    (test-error (length '#(x y)))
155    (test-error (length "foo")))
156
157  (test-group "append"
158    (test '(x y) (append '(x) '(y)))
159    (test '(a b c d) (append '(a) '(b c d)))
160    (test '(a (b) (c)) (append '(a (b)) '((c))))
161    (test '(a b c . d) (append '(a b) '(c . d)))
162    (test 'a (append '() 'a))
163    (test '(a b . c) (append '(a b) 'c))
164    (test-error (append 'x '()))
165    (test-error (append '(x) 'y '())))
166
167  (test-group "reverse"
168    (test '(c b a) (reverse '(a b c)))
169    (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
170    (test '() (reverse '()))
171    (test-error (reverse '(a . b)))
172    (test-error (reverse '(a b) '(c d)))
173    (test-error (reverse 'a))
174    (test-error (reverse '#(a b c)))
175    (test-error (reverse "foo")))
176
177  (test-group "list-tail"
178    (test '(a b c d e f) (list-tail '(a b c d e f) 0))
179    (test '(d e f) (list-tail '(a b c d e f) 3))
180    (test '() (list-tail '(a b c d e f) 6))
181    (test '() (list-tail '() 0))
182    (test-error (list-tail '(a b c d e f) -1))
183    (test-error (list-tail '(a b c d e f) 7))
184    (test-error (list-tail '(a b c d e . f) 6)))
185
186  (test-group "list-ref"
187    (test 'a (list-ref '(a b c d) 0))
188    (test 'b (list-ref '(a b c d) 1))
189    (test 'c (list-ref '(a b c d) 2))
190    (test 'd (list-ref '(a b c d) 3))
191    (test-error (list-ref '(a b c d) 4))
192    (test-error (list-ref '(a b c d) -1)))
193
194  (test-group "list-set!"
195    (let ((ls (list 'one 'two 'five!)))
196      (list-set! ls 2 'three)
197      (test '(two three) (cdr ls)))
198    ;; Should be an error?
199    #;(list-set! '(0 1 2) 1 "oops")
200    (test-error (list-set! (list 1 2 3) 3 'foo)))
201
202  (test-group "mem*"
203    (test '(a b c) (memq 'a '(a b c)))
204    (test '(b c) (memq 'b '(a b c)))
205    (test #f (memq 'a '(b c d)))
206    (test #f (memq (list 'a) '(b (a) c)))
207    (test '((a) c) (member (list 'a) '(b (a) c)))
208    (test '("b" "c") (member "B" '("a" "b" "c") string-ci=?))
209    (test '(101 102) (memq 101 '(100 101 102))) ; unspecified in R7RS
210    (test '(101 102) (memv 101 '(100 101 102))))
211
212  (test-group "ass*"
213    (define e '((a 1) (b 2) (c 3)))
214    (test '(a 1) (assq 'a e))
215    (test '(b 2) (assq 'b e))
216    (test #f (assq 'd e))
217    (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
218    (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
219    (test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =))
220    (test '(5 7) (assq 5 '((2 3) (5 7) (11 13)))) ; unspecified in R7RS
221    (test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
222    (test-error (assq 5 '(5 6 7)))
223    (test-error (assv 5 '(5 6 7)))
224    (test-error (assoc 5 '(5 6 7))))
225
226  (test-group "list-copy"
227   (define a '(1 8 2 8)) ; a may be immutable
228   (define b (list-copy a))
229   (set-car! b 3)        ; b is mutable
230   (test '((3 8 2 8)) (list b))
231   (test '((1 8 2 8)) (list a))))
232
233(define-syntax catch
234  (syntax-rules ()
235    ((_ . body) (handle-exceptions e e . body))))
236
237(test-group "exceptions"
238  (test "with-exception-handler (escape)"
239        'exception
240        (call-with-current-continuation
241         (lambda (k)
242           (with-exception-handler
243            (lambda (e) (k 'exception))
244            (lambda () (+ 1 (raise 'an-error)))))))
245  (test-error "with-exception-handler (return)"
246              (with-exception-handler
247               (lambda (e) 'ignore)
248               (lambda () (+ 1 (raise 'an-error)))))
249  (test-error "with-exception-handler (raise)"
250              (with-exception-handler
251               (lambda (e) (raise 'another-error))
252               (lambda () (+ 1 (raise 'an-error)))))
253  (test "with-exception-handler (raise-continuable)"
254        '("should be a number" 65)
255        (let* ((exception-object #f)
256               (return-value 
257                (with-exception-handler
258                 (lambda (e) (set! exception-object e) 42)
259                 (lambda () (+ (raise-continuable "should be a number") 23)))))
260          (list exception-object return-value)))
261  (test "error-object? (#f)" #f (error-object? 'no))
262  (test "error-object? (#t)" #t (error-object? (catch (car '()))))
263  (test "error-object-message" "fubar" (error-object-message (catch (error "fubar"))))
264  (test "error-object-irritants" '(42) (error-object-irritants (catch (error "fubar" 42))))
265  (test "read-error? (#f)" #f (read-error? (catch (car '()))))
266  (test "read-error? (#t)" #t (read-error? (catch (read-from-string ")"))))
267  (test "file-error? (#f)" #f (file-error? (catch (car '()))))
268  (test "file-error? (#t)" #t (file-error? (catch (open-input-file "foo"))))
269  (test-error "guard (no match)"
270              (guard (condition ((assq 'c condition))) (raise '((a . 42)))))
271  (test "guard (match)"
272        '(b . 23)
273        (guard (condition ((assq 'b condition))) (raise '((b . 23)))))
274  (test "guard (=>)"
275        42
276        (guard (condition ((assq 'a condition) => cdr)) (raise '((a . 42)))))
277  (test "guard (multiple)"
278        '(b . 23)
279        (guard (condition
280                ((assq 'a condition) => cdr)
281                ((assq 'b condition)))
282               (raise '((b . 23))))))
283
284;; call-with-port is not supposed to close its port when leaving the
285;; dynamic extent, only on normal return.
286;;
287;; XXX TODO: Rewrite in terms of SRFI-6 string port interface, so
288;; no call-with-*-string, but use get-output-string and such!
289;; Do this when it's clear how to re-export Chicken stuff.
290(test-group "string ports"
291  (receive (jump-back? jump!)
292      (call/cc (lambda (k) (values #f k)))
293    (when jump-back? (jump! (void)))
294    (let ((string (call-with-output-string
295                   (lambda (the-string-port)
296                     (receive (one two three)
297                         (call-with-port the-string-port
298                          (lambda (p)
299                            (display "foo" p)
300                            ;; Leave the dynamic extent momentarily;
301                            ;; jump! will immediately return with #t.
302                            (call/cc (lambda (k) (jump! #t k)))
303                            (test-assert "Port is still open after excursion"
304                                         (output-port-open? the-string-port))
305                            (display "bar" p)
306                            (values 1 2 3)))
307                       (test "call-with-port returns all values yielded by proc"
308                             '(1 2 3)
309                             (list one two three)))
310                     (test-assert "call-with-port closes the port on normal return"
311                                  (not (output-port-open? the-string-port)))
312                     (test-assert "It's ok to close output ports that are closed"
313                                  (close-port the-string-port))
314                     (test-error "input-port-open? fails on output ports"
315                                 (input-port-open? the-string-port))))))
316      (test "call-with-port passes the port correctly and allows temporary escapes"
317            "foobar" string)))
318
319  (call-with-input-string "foo"
320    (lambda (the-string-port)
321      (test-error "output-port-open? fails on input ports"
322                  (output-port-open? the-string-port))
323      (test-assert "Initially, string port is open"
324                   (input-port-open? the-string-port))
325      (test "Reading from string delivers the data"
326            'foo (read the-string-port))
327      (test "After reading all, we get the eof-object"
328            (eof-object) (read the-string-port))
329      (test-assert "Port is still open after all reads"
330                   (input-port-open? the-string-port))
331      (close-port the-string-port)
332      (test-assert "Port is no longer open after closing it"
333                   (not (input-port-open? the-string-port)))
334      (test-assert "It's ok to close input ports that are already closed"
335                   (close-port the-string-port)))))
336
337;; This is for later. We can't define it inside a group because that
338;; would make it locally scoped (as a letrec rewrite), which breaks
339;; the syntax-rules underscore tests.  Very subtle (and annoying), this!
340(define (_) 'underscore-procedure)
341(define ___ 'triple-underscore-literal)
342
343(test-group "syntax-rules"
344  (test "let-syntax w/ basic syntax-rules"
345        100
346        (let-syntax ((foo (syntax-rules ()
347                            ((_ x form)
348                             (let ((tmp x))
349                               (if (number? tmp)
350                                   form
351                                   (error "not a number" tmp)))))))
352          (foo 2 100)))
353  (let-syntax ((foo (syntax-rules ()
354                      ((_ #(a ...)) (list a ...)))))
355    (test "Basic matching of vectors"
356          '(1 2 3) (foo #(1 2 3))))
357  ;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
358  (let-syntax ((foo (syntax-rules ()
359                      ((_ (a b) ...)
360                       (list 'first '(a b) ...))
361                      ((_ a ...)
362                       (list 'second '(a) ...)))))
363    (test "Basic ellipsis match"
364          '(first (1 2) (3 4) (5 6)) (foo (1 2) (3 4) (5 6)))
365    (test "Ellipsis match of length 1 does not match length 2"
366          '(second (1)) (foo 1))
367    (test "Ellipsis match of lists with mismatched lengths (used to fail)"
368          '(second ((1 2)) ((3)) ((5 6))) (foo (1 2) (3) (5 6))))
369
370  (test "letrec-syntax"
371        34
372        (letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))
373                        (bar (syntax-rules () ((_ x) (+ x 1)))))
374          (foo 33)))
375  (test "Basic hygienic rename of syntactic keywords"
376        'now
377        (let-syntax ((when (syntax-rules ()
378                             ((when test stmt1 stmt2 ...)
379                              (if test
380                                  (begin stmt1
381                                         stmt2 ...))))))
382          (let ((if #t))
383            (when if (set! if 'now))
384            if)))
385  (test "Basic hygienic rename of shadowed outer let"
386        'outer
387        (let ((x 'outer))
388          (let-syntax ((m (syntax-rules () ((m) x))))
389            (let ((x 'inner))
390              (m)))))
391  (test "Simple recursive letrec expansion"
392        7
393        (letrec-syntax
394            ((my-or (syntax-rules ()
395                      ((my-or) #f)
396                      ((my-or e) e)
397                      ((my-or e1 e2 ...)
398                       (let ((temp e1))
399                         (if temp
400                             temp
401                             (my-or e2 ...)))))))
402          (let ((x #f)
403                (y 7)
404                (temp 8)
405                (let odd?)
406                (if even?))
407            (my-or x
408                   (let temp)
409                   (if y)
410                   y))))
411  ;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"
412  (let ((a 1))
413    (letrec-syntax
414        ((foo (syntax-rules ()
415                ((_ b)
416                 (bar a b))))
417         (bar (syntax-rules ()
418                ((_ c d)
419                 (cons c (let ((c 3))
420                           (list d c 'c)))))))
421      (let ((a 2))
422        (test "Al* Petrofsky torture test" '(1 2 3 a) (foo a)))))
423  (let-syntax
424      ((foo (syntax-rules ()
425              ((_)
426               '#(b)))))
427    (test "Quoted symbols inside vectors are stripped of syntactic info"
428          '#(b) (foo)))
429  (let-syntax ((kw (syntax-rules (baz)
430                     ((_ baz) "baz")
431                     ((_ any) "no baz"))))
432    (test "syntax-rules keywords match" "baz" (kw baz))
433    (test "syntax-rules keywords no match" "no baz" (kw xxx))
434    (let ((baz 100))
435      (test "keyword loses meaning if shadowed" "no baz" (kw baz))))
436  (test "keyword also loses meaning for builtins (from R7RS section 4.3.2)"
437        'ok
438        (let ((=> #f))
439          (cond (#t => 'ok))))
440  (test "Nested identifier shadowing works correctly"
441        '(3 4)
442        (let ((foo 3))
443          (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))
444            (let ((foo 4))
445              (bar foo)))))
446  (let-syntax ((c (syntax-rules ()
447                    ((_)
448                     (let ((x 10))
449                       (let-syntax ((z (syntax-rules ()
450                                         ((_) (quote x)))))
451                         (z))))))
452               (c2 (syntax-rules ()
453                     ((_)
454                      (let ((x 10))
455                        (let-syntax
456                            ((z (syntax-rules ()
457                                  ((_) (let-syntax
458                                           ((w (syntax-rules ()
459                                                 ((_) (quote x)))))
460                                         (w))))))
461                          (z)))))))
462    ;; Reported by Matthew Flatt
463    (test "strip-syntax cuts across three levels of syntax"
464          "x" (symbol->string (c)))
465    (test "strip-syntax cuts across four levels of syntax"
466          "x" (symbol->string (c2))))
467  (let-syntax ((foo (syntax-rules
468                        ___ () 
469                        ((_ vals ___) (list '... vals ___)))))
470    (test "Alternative ellipsis (from SRFI-46)"
471          '(... 1 2 3) (foo 1 2 3)))
472  (let-syntax ((let-alias (syntax-rules
473                              ___ ()
474                              ((_ new old code ___)
475                               (let-syntax
476                                   ((new
477                                     (syntax-rules ()
478                                       ((_ args ...) (old args ...)))))
479                                 code ___)))))
480    (let-alias inc (lambda (x) (+ 1 x))
481               (test "Ellipsis rules are reset in new macro expansion phase"
482                     3 (inc 2))))
483  (let-syntax ((foo (syntax-rules ()
484                      ((_ (a ... b) ... (c d))
485                       (list (list (list a ...) ... b ...) c d))
486                      ((_ #(a ... b) ... #(c d) #(e f))
487                       (list (list (vector a ...) ... b ...) c d e f))
488                      ((_ #(a ... b) ... #(c d))
489                       (list (list (vector a ...) ... b ...) c d)))))
490    (test-group "rest patterns after ellipsis (SRFI-46 smoke test)"
491      (test '(() 1 2) (foo (1 2)))
492      (test '(((1) 2) 3 4) (foo (1 2) (3 4)))
493      (test '(((1 2) (4) 3 5) 6 7)
494            (foo (1 2 3) (4 5) (6 7)))
495      (test '(() 1 2)
496            (foo #(1 2)))
497      (test '((#() 1) 2 3)
498            (foo #(1) #(2 3)))
499      (test '((#(1 2) 3) 4 5)
500            (foo #(1 2 3) #(4 5)))
501      (test '((#(1 2) 3) 4 5 6 7)
502            (foo #(1 2 3) #(4 5) #(6 7)))
503      (test '(() 1 2 3 4)
504            (foo #(1 2) #(3 4)))
505      (test '((#(1) 2) 3 4 5 6)
506            (foo #(1 2) #(3 4) #(5 6)))
507      (test '((#(1 2) #(4) 3 5) 6 7 8 9)
508            (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))))
509  (let-syntax ((foo (syntax-rules ()
510                      ((_ #((a) ...)) (list a ...)))))
511    (test "Bug discovered during implementation of rest patterns"
512          '(1)
513          (foo #((1)))))
514  ;; R7RS: (<ellipsis> <template>) is like <template>, ignoring
515  ;; occurrances of <ellipsis> inside the template.
516  (let-syntax ((be-like-begin
517                (syntax-rules ()
518                  ((be-like-begin name)
519                   (define-syntax name
520                     (syntax-rules ()
521                       ((name expr (... ...))
522                        (begin expr (... ...)))))))))
523    (be-like-begin sequence)
524    (test "be-like-begin from R7RS 4.3.2 (nested ellipsis are not expanded)"
525          4 (sequence 1 2 3 4)))
526  (let-syntax ((ignore-underscores
527                (syntax-rules ()
528                  ((_ _ _ _) (_)))))
529    (test "underscores are ignored in patterns"
530          'underscore-procedure (ignore-underscores _ b c)))
531
532  (test-group "undefined behaviours: mixing keywords, ellipsis and underscores"
533    (test-group "underscore as keyword literal"
534      (define-syntax match-literal-underscores ; for eval
535        (syntax-rules (_)
536          ((x a _ c) (_))
537          ((x _ b c) 1)))
538      (test-error "Missing literal underscore keyword causes syntax-error"
539                  (eval '(match-literal-underscores d e f)))
540      (test "Literal underscore matches"
541            1 (match-literal-underscores _ h i))
542      (test "Literal underscore matches even if it refers to toplevel binding"
543            'underscore-procedure (match-literal-underscores g _ i)))
544   
545    (test-group "underscore as ellipsis"
546     ;; It's undefined what this should do.  Logically, it should be
547     ;; possible to bind _ as an ellipsis identifier.
548     (define-syntax match-ellipsis-underscores ; for eval
549       (syntax-rules _ () ((x a _ c) (list a _ c))))
550     (test-error "No rule matching if prefix is omitted"
551                 (eval '(match-ellipsis-underscores)))
552     (test "Only prefix is supplied"
553           '(1) (match-ellipsis-underscores 1))
554     (test "Ellipsis does its work if multiple arguments given"
555           '(1 2 3 4 5 6) (match-ellipsis-underscores 1 2 3 4 5 6)))
556
557    (test-group "underscore as ellipsis mixed with underscore literal"
558      ;; Even more undefined behaviour: mixing literals and ellipsis identifiers
559      ;; Currently, ellipsis identifiers have precedence over the other two.
560      (define-syntax match-ellipsis-and-literals-underscores ; for eval
561        (syntax-rules _ (_) ((x a _ c) (list a _ c))))
562      (test-error "No rule matching if prefix is omitted"
563                  (eval '(match-ellipsis-and-literals-underscores)))
564      (test '(1) (match-ellipsis-and-literals-underscores 1))
565      (test '(1 2 3) (match-ellipsis-and-literals-underscores 1 2 3))
566      (test '(1 2 3 4 5 6) (match-ellipsis-and-literals-underscores 1 2 3 4 5 6)))
567
568    (test-group "\"custom\" ellipsis and literal of the same identifier"
569      ;; This is similar to the above, but maybe a little simpler because
570      ;; it does not use reserved names:
571      (define-syntax match-ellipsis-literals
572        (syntax-rules ___ (___)
573                      ((_ x ___) (list x ___))))
574      (test "Ellipsis as literals"
575            '(1) (match-ellipsis-literals 1))
576      (test "Ellipsis as literals multiple args"
577            '(1 2) (match-ellipsis-literals 1 2))
578      (test "Toplevel binding of the same name as ellipsis"
579            '(1 triple-underscore-literal) (match-ellipsis-literals 1 ___))))
580
581  (letrec-syntax ((usetmp
582                   (syntax-rules ()
583                     ((_ var) 
584                      (list var))))
585                  (withtmp
586                   (syntax-rules ()
587                     ((_ val exp)
588                      (let ((tmp val))
589                        (exp tmp))))))
590    (test "Passing a macro as argument to macro"
591          '(99)
592          (withtmp 99 usetmp)))
593
594  ;; renaming of keyword argument (#277)
595  (let-syntax ((let-hello-proc
596                (syntax-rules ()
597                  ((_ procname code ...)
598                   (let ((procname (lambda (#!key (who "world"))
599                                     (string-append "hello, " who))))
600                     code ...)))))
601    (let-hello-proc bar
602         ;; This is not R7RS, but R7RS should not interfere with other
603         ;; CHICKEN features!
604         (test "DSSSL keyword arguments aren't renamed (not R7RS)"
605               "hello, XXX" (bar who: "XXX")))))
606
607(test-end "r7rs tests")
608
609(test-exit)
Note: See TracBrowser for help on using the repository browser.