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

Last change on this file since 29954 was 29954, checked in by evhan, 8 years ago

r7rs: Extended-arity char*? and string*? comparators

File size: 27.2 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(test-group "6.6: characters"
303  (test-group "char*?"
304    (test-error "arity" (char=? #\a))
305    (test-error "type check" (char=? #\a #\a 1))
306    (test-error "no shortcutting" (char=? #\a #\b 1))
307    (test #t (char=? #\a #\a))
308    (test #f (char=? #\a #\b))
309    (test #t (char=? #\a #\a #\a))
310    (test #f (char=? #\a #\b #\a))
311    (test #f (char=? #\a #\a #\b))
312    (test #t (char=? #\a #\a #\a #\a))
313    (test #f (char=? #\a #\b #\a #\a))
314    (test #f (char=? #\a #\a #\a #\b))
315    (test #t (char<? #\a #\b #\c))
316    (test #f (char<? #\a #\b #\b))
317    (test #t (char<=? #\a #\b #\b))
318    (test #f (char<=? #\a #\b #\a))
319    (test #t (char>? #\c #\b #\a))
320    (test #f (char>? #\a #\a #\a))
321    (test #t (char>=? #\b #\b #\a))
322    (test #f (char>=? #\b #\a #\b))))
323
324(test-group "6.7: strings"
325  (test-group "string*?"
326    (test-error "arity" (string=? "a"))
327    (test-error "type check" (string=? "a" "a" 1))
328    (test-error "no shortcutting" (string=? "a" "b" 1))
329    (test #t (string=? "a" "a"))
330    (test #f (string=? "a" "b"))
331    (test #t (string=? "a" "a" "a"))
332    (test #f (string=? "a" "b" "a"))
333    (test #f (string=? "a" "a" "b"))
334    (test #t (string=? "a" "a" "a" "a"))
335    (test #f (string=? "a" "b" "a" "a"))
336    (test #f (string=? "a" "a" "a" "b"))
337    (test #t (string<? "a" "b" "c"))
338    (test #f (string<? "a" "b" "b"))
339    (test #t (string<=? "a" "b" "b"))
340    (test #f (string<=? "a" "b" "a"))
341    (test #t (string>? "c" "b" "a"))
342    (test #f (string>? "c" "b" "b"))
343    (test #t (string>=? "b" "b" "a"))
344    (test #f (string>=? "b" "a" "b"))))
345
346(define-syntax catch
347  (syntax-rules ()
348    ((_ . body) (handle-exceptions e e . body))))
349
350(test-group "exceptions"
351  (test "with-exception-handler (escape)"
352        'exception
353        (call-with-current-continuation
354         (lambda (k)
355           (with-exception-handler
356            (lambda (e) (k 'exception))
357            (lambda () (+ 1 (raise 'an-error)))))))
358  (test-error "with-exception-handler (return)"
359              (with-exception-handler
360               (lambda (e) 'ignore)
361               (lambda () (+ 1 (raise 'an-error)))))
362  (test-error "with-exception-handler (raise)"
363              (with-exception-handler
364               (lambda (e) (raise 'another-error))
365               (lambda () (+ 1 (raise 'an-error)))))
366  (test "with-exception-handler (raise-continuable)"
367        '("should be a number" 65)
368        (let* ((exception-object #f)
369               (return-value 
370                (with-exception-handler
371                 (lambda (e) (set! exception-object e) 42)
372                 (lambda () (+ (raise-continuable "should be a number") 23)))))
373          (list exception-object return-value)))
374  (test "error-object? (#f)" #f (error-object? 'no))
375  (test "error-object? (#t)" #t (error-object? (catch (car '()))))
376  (test "error-object-message" "fubar" (error-object-message (catch (error "fubar"))))
377  (test "error-object-irritants" '(42) (error-object-irritants (catch (error "fubar" 42))))
378  (test "read-error? (#f)" #f (read-error? (catch (car '()))))
379  (test "read-error? (#t)" #t (read-error? (catch (read-from-string ")"))))
380  (test "file-error? (#f)" #f (file-error? (catch (car '()))))
381  (test "file-error? (#t)" #t (file-error? (catch (open-input-file "foo"))))
382  (test-error "guard (no match)"
383              (guard (condition ((assq 'c condition))) (raise '((a . 42)))))
384  (test "guard (match)"
385        '(b . 23)
386        (guard (condition ((assq 'b condition))) (raise '((b . 23)))))
387  (test "guard (=>)"
388        42
389        (guard (condition ((assq 'a condition) => cdr)) (raise '((a . 42)))))
390  (test "guard (multiple)"
391        '(b . 23)
392        (guard (condition
393                ((assq 'a condition) => cdr)
394                ((assq 'b condition)))
395               (raise '((b . 23))))))
396
397;; call-with-port is not supposed to close its port when leaving the
398;; dynamic extent, only on normal return.
399;;
400;; XXX TODO: Rewrite in terms of SRFI-6 string port interface, so
401;; no call-with-*-string, but use get-output-string and such!
402;; Do this when it's clear how to re-export Chicken stuff.
403(test-group "string ports"
404  (receive (jump-back? jump!)
405      (call/cc (lambda (k) (values #f k)))
406    (when jump-back? (jump! (void)))
407    (let ((string (call-with-output-string
408                   (lambda (the-string-port)
409                     (receive (one two three)
410                         (call-with-port the-string-port
411                          (lambda (p)
412                            (display "foo" p)
413                            ;; Leave the dynamic extent momentarily;
414                            ;; jump! will immediately return with #t.
415                            (call/cc (lambda (k) (jump! #t k)))
416                            (test-assert "Port is still open after excursion"
417                                         (output-port-open? the-string-port))
418                            (display "bar" p)
419                            (values 1 2 3)))
420                       (test "call-with-port returns all values yielded by proc"
421                             '(1 2 3)
422                             (list one two three)))
423                     (test-assert "call-with-port closes the port on normal return"
424                                  (not (output-port-open? the-string-port)))
425                     (test-assert "It's ok to close output ports that are closed"
426                                  (close-port the-string-port))
427                     (test-error "input-port-open? fails on output ports"
428                                 (input-port-open? the-string-port))))))
429      (test "call-with-port passes the port correctly and allows temporary escapes"
430            "foobar" string)))
431
432  (call-with-input-string "foo"
433    (lambda (the-string-port)
434      (test-error "output-port-open? fails on input ports"
435                  (output-port-open? the-string-port))
436      (test-assert "Initially, string port is open"
437                   (input-port-open? the-string-port))
438      (test "Reading from string delivers the data"
439            'foo (read the-string-port))
440      (test "After reading all, we get the eof-object"
441            (eof-object) (read the-string-port))
442      (test-assert "Port is still open after all reads"
443                   (input-port-open? the-string-port))
444      (close-port the-string-port)
445      (test-assert "Port is no longer open after closing it"
446                   (not (input-port-open? the-string-port)))
447      (test-assert "It's ok to close input ports that are already closed"
448                   (close-port the-string-port)))))
449
450;; This is for later. We can't define it inside a group because that
451;; would make it locally scoped (as a letrec rewrite), which breaks
452;; the syntax-rules underscore tests.  Very subtle (and annoying), this!
453(define (_) 'underscore-procedure)
454(define ___ 'triple-underscore-literal)
455
456(test-group "syntax-rules"
457  (test "let-syntax w/ basic syntax-rules"
458        100
459        (let-syntax ((foo (syntax-rules ()
460                            ((_ x form)
461                             (let ((tmp x))
462                               (if (number? tmp)
463                                   form
464                                   (error "not a number" tmp)))))))
465          (foo 2 100)))
466  (let-syntax ((foo (syntax-rules ()
467                      ((_ #(a ...)) (list a ...)))))
468    (test "Basic matching of vectors"
469          '(1 2 3) (foo #(1 2 3))))
470  ;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
471  (let-syntax ((foo (syntax-rules ()
472                      ((_ (a b) ...)
473                       (list 'first '(a b) ...))
474                      ((_ a ...)
475                       (list 'second '(a) ...)))))
476    (test "Basic ellipsis match"
477          '(first (1 2) (3 4) (5 6)) (foo (1 2) (3 4) (5 6)))
478    (test "Ellipsis match of length 1 does not match length 2"
479          '(second (1)) (foo 1))
480    (test "Ellipsis match of lists with mismatched lengths (used to fail)"
481          '(second ((1 2)) ((3)) ((5 6))) (foo (1 2) (3) (5 6))))
482
483  (test "letrec-syntax"
484        34
485        (letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))
486                        (bar (syntax-rules () ((_ x) (+ x 1)))))
487          (foo 33)))
488  (test "Basic hygienic rename of syntactic keywords"
489        'now
490        (let-syntax ((when (syntax-rules ()
491                             ((when test stmt1 stmt2 ...)
492                              (if test
493                                  (begin stmt1
494                                         stmt2 ...))))))
495          (let ((if #t))
496            (when if (set! if 'now))
497            if)))
498  (test "Basic hygienic rename of shadowed outer let"
499        'outer
500        (let ((x 'outer))
501          (let-syntax ((m (syntax-rules () ((m) x))))
502            (let ((x 'inner))
503              (m)))))
504  (test "Simple recursive letrec expansion"
505        7
506        (letrec-syntax
507            ((my-or (syntax-rules ()
508                      ((my-or) #f)
509                      ((my-or e) e)
510                      ((my-or e1 e2 ...)
511                       (let ((temp e1))
512                         (if temp
513                             temp
514                             (my-or e2 ...)))))))
515          (let ((x #f)
516                (y 7)
517                (temp 8)
518                (let odd?)
519                (if even?))
520            (my-or x
521                   (let temp)
522                   (if y)
523                   y))))
524  ;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"
525  (let ((a 1))
526    (letrec-syntax
527        ((foo (syntax-rules ()
528                ((_ b)
529                 (bar a b))))
530         (bar (syntax-rules ()
531                ((_ c d)
532                 (cons c (let ((c 3))
533                           (list d c 'c)))))))
534      (let ((a 2))
535        (test "Al* Petrofsky torture test" '(1 2 3 a) (foo a)))))
536  (let-syntax
537      ((foo (syntax-rules ()
538              ((_)
539               '#(b)))))
540    (test "Quoted symbols inside vectors are stripped of syntactic info"
541          '#(b) (foo)))
542  (let-syntax ((kw (syntax-rules (baz)
543                     ((_ baz) "baz")
544                     ((_ any) "no baz"))))
545    (test "syntax-rules keywords match" "baz" (kw baz))
546    (test "syntax-rules keywords no match" "no baz" (kw xxx))
547    (let ((baz 100))
548      (test "keyword loses meaning if shadowed" "no baz" (kw baz))))
549  (test "keyword also loses meaning for builtins (from R7RS section 4.3.2)"
550        'ok
551        (let ((=> #f))
552          (cond (#t => 'ok))))
553  (test "Nested identifier shadowing works correctly"
554        '(3 4)
555        (let ((foo 3))
556          (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))
557            (let ((foo 4))
558              (bar foo)))))
559  (let-syntax ((c (syntax-rules ()
560                    ((_)
561                     (let ((x 10))
562                       (let-syntax ((z (syntax-rules ()
563                                         ((_) (quote x)))))
564                         (z))))))
565               (c2 (syntax-rules ()
566                     ((_)
567                      (let ((x 10))
568                        (let-syntax
569                            ((z (syntax-rules ()
570                                  ((_) (let-syntax
571                                           ((w (syntax-rules ()
572                                                 ((_) (quote x)))))
573                                         (w))))))
574                          (z)))))))
575    ;; Reported by Matthew Flatt
576    (test "strip-syntax cuts across three levels of syntax"
577          "x" (symbol->string (c)))
578    (test "strip-syntax cuts across four levels of syntax"
579          "x" (symbol->string (c2))))
580  (let-syntax ((foo (syntax-rules
581                        ___ () 
582                        ((_ vals ___) (list '... vals ___)))))
583    (test "Alternative ellipsis (from SRFI-46)"
584          '(... 1 2 3) (foo 1 2 3)))
585  (let-syntax ((let-alias (syntax-rules
586                              ___ ()
587                              ((_ new old code ___)
588                               (let-syntax
589                                   ((new
590                                     (syntax-rules ()
591                                       ((_ args ...) (old args ...)))))
592                                 code ___)))))
593    (let-alias inc (lambda (x) (+ 1 x))
594               (test "Ellipsis rules are reset in new macro expansion phase"
595                     3 (inc 2))))
596  (let-syntax ((foo (syntax-rules ()
597                      ((_ (a ... b) ... (c d))
598                       (list (list (list a ...) ... b ...) c d))
599                      ((_ #(a ... b) ... #(c d) #(e f))
600                       (list (list (vector a ...) ... b ...) c d e f))
601                      ((_ #(a ... b) ... #(c d))
602                       (list (list (vector a ...) ... b ...) c d)))))
603    (test-group "rest patterns after ellipsis (SRFI-46 smoke test)"
604      (test '(() 1 2) (foo (1 2)))
605      (test '(((1) 2) 3 4) (foo (1 2) (3 4)))
606      (test '(((1 2) (4) 3 5) 6 7)
607            (foo (1 2 3) (4 5) (6 7)))
608      (test '(() 1 2)
609            (foo #(1 2)))
610      (test '((#() 1) 2 3)
611            (foo #(1) #(2 3)))
612      (test '((#(1 2) 3) 4 5)
613            (foo #(1 2 3) #(4 5)))
614      (test '((#(1 2) 3) 4 5 6 7)
615            (foo #(1 2 3) #(4 5) #(6 7)))
616      (test '(() 1 2 3 4)
617            (foo #(1 2) #(3 4)))
618      (test '((#(1) 2) 3 4 5 6)
619            (foo #(1 2) #(3 4) #(5 6)))
620      (test '((#(1 2) #(4) 3 5) 6 7 8 9)
621            (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))))
622  (let-syntax ((foo (syntax-rules ()
623                      ((_ #((a) ...)) (list a ...)))))
624    (test "Bug discovered during implementation of rest patterns"
625          '(1)
626          (foo #((1)))))
627  ;; R7RS: (<ellipsis> <template>) is like <template>, ignoring
628  ;; occurrances of <ellipsis> inside the template.
629  (let-syntax ((be-like-begin
630                (syntax-rules ()
631                  ((be-like-begin name)
632                   (define-syntax name
633                     (syntax-rules ()
634                       ((name expr (... ...))
635                        (begin expr (... ...)))))))))
636    (be-like-begin sequence)
637    (test "be-like-begin from R7RS 4.3.2 (nested ellipsis are not expanded)"
638          4 (sequence 1 2 3 4)))
639  (let-syntax ((ignore-underscores
640                (syntax-rules ()
641                  ((_ _ _ _) (_)))))
642    (test "underscores are ignored in patterns"
643          'underscore-procedure (ignore-underscores _ b c)))
644
645  (test-group "undefined behaviours: mixing keywords, ellipsis and underscores"
646    (test-group "underscore as keyword literal"
647      (define-syntax match-literal-underscores ; for eval
648        (syntax-rules (_)
649          ((x a _ c) (_))
650          ((x _ b c) 1)))
651      (test-error "Missing literal underscore keyword causes syntax-error"
652                  (eval '(match-literal-underscores d e f)))
653      (test "Literal underscore matches"
654            1 (match-literal-underscores _ h i))
655      (test "Literal underscore matches even if it refers to toplevel binding"
656            'underscore-procedure (match-literal-underscores g _ i)))
657   
658    (test-group "underscore as ellipsis"
659     ;; It's undefined what this should do.  Logically, it should be
660     ;; possible to bind _ as an ellipsis identifier.
661     (define-syntax match-ellipsis-underscores ; for eval
662       (syntax-rules _ () ((x a _ c) (list a _ c))))
663     (test-error "No rule matching if prefix is omitted"
664                 (eval '(match-ellipsis-underscores)))
665     (test "Only prefix is supplied"
666           '(1) (match-ellipsis-underscores 1))
667     (test "Ellipsis does its work if multiple arguments given"
668           '(1 2 3 4 5 6) (match-ellipsis-underscores 1 2 3 4 5 6)))
669
670    (test-group "underscore as ellipsis mixed with underscore literal"
671      ;; Even more undefined behaviour: mixing literals and ellipsis identifiers
672      ;; Currently, ellipsis identifiers have precedence over the other two.
673      (define-syntax match-ellipsis-and-literals-underscores ; for eval
674        (syntax-rules _ (_) ((x a _ c) (list a _ c))))
675      (test-error "No rule matching if prefix is omitted"
676                  (eval '(match-ellipsis-and-literals-underscores)))
677      (test '(1) (match-ellipsis-and-literals-underscores 1))
678      (test '(1 2 3) (match-ellipsis-and-literals-underscores 1 2 3))
679      (test '(1 2 3 4 5 6) (match-ellipsis-and-literals-underscores 1 2 3 4 5 6)))
680
681    (test-group "\"custom\" ellipsis and literal of the same identifier"
682      ;; This is similar to the above, but maybe a little simpler because
683      ;; it does not use reserved names:
684      (define-syntax match-ellipsis-literals
685        (syntax-rules ___ (___)
686                      ((_ x ___) (list x ___))))
687      (test "Ellipsis as literals"
688            '(1) (match-ellipsis-literals 1))
689      (test "Ellipsis as literals multiple args"
690            '(1 2) (match-ellipsis-literals 1 2))
691      (test "Toplevel binding of the same name as ellipsis"
692            '(1 triple-underscore-literal) (match-ellipsis-literals 1 ___))))
693
694  (letrec-syntax ((usetmp
695                   (syntax-rules ()
696                     ((_ var) 
697                      (list var))))
698                  (withtmp
699                   (syntax-rules ()
700                     ((_ val exp)
701                      (let ((tmp val))
702                        (exp tmp))))))
703    (test "Passing a macro as argument to macro"
704          '(99)
705          (withtmp 99 usetmp)))
706
707  ;; renaming of keyword argument (#277)
708  (let-syntax ((let-hello-proc
709                (syntax-rules ()
710                  ((_ procname code ...)
711                   (let ((procname (lambda (#!key (who "world"))
712                                     (string-append "hello, " who))))
713                     code ...)))))
714    (let-hello-proc bar
715         ;; This is not R7RS, but R7RS should not interfere with other
716         ;; CHICKEN features!
717         (test "DSSSL keyword arguments aren't renamed (not R7RS)"
718               "hello, XXX" (bar who: "XXX")))))
719
720(test-end "r7rs tests")
721
722(test-exit)
Note: See TracBrowser for help on using the repository browser.