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

Last change on this file since 29599 was 29599, checked in by sjamaan, 8 years ago

r7rs: import and export the quotient/remainder division procedures. Update numbers dependency version to 2.9

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