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

Last change on this file since 30325 was 30325, checked in by evhan, 7 years ago

r7rs: most of scheme.base, stub rest of libs, define-library/inclusion fixes

File size: 36.5 KB
Line 
1(use r7rs)
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(import (chicken)
9        (test)
10        (ports)
11        (scheme base)
12        (scheme char)
13        (scheme file)
14        (scheme read)
15        (scheme write))
16
17(define (read-from-string s)
18  (with-input-from-string s read))
19
20(test-begin "r7rs tests")
21
22(test-group "4.1.7: Inclusion"
23  (test-group "include"
24    (test "multiple filenames"
25          "abcabc"
26          (with-output-to-string
27           (lambda () (include "include.scm" "include.scm"))))
28    (test-error "case sensitivity"
29                (with-output-to-string
30                 (lambda () (include "include-ci.scm")))))
31  (test-group "include-ci"
32    (test "multiple filenames"
33          "abcabc"
34          (with-output-to-string
35           (lambda () (include-ci "include.scm" "include.scm"))))
36    (test "case sensitivity"
37          "abc"
38          (with-output-to-string
39           (lambda () (include-ci "include-ci.scm"))))))
40
41(test-group "6.2.6: numerical operations"
42  (test-group "floor/...truncate-remainder"
43    (test '(2 1)      (receive (floor/ 5 2)))
44    (test 2           (floor-quotient 5 2))
45    (test 1           (floor-remainder 5 2))
46    (test '(-3 1)     (receive (floor/ -5 2)))
47    (test -3          (floor-quotient -5 2))
48    (test 1           (floor-remainder -5 2))
49    (test '(-3 -1)    (receive (floor/ 5 -2)))
50    (test -3          (floor-quotient 5 -2))
51    (test -1          (floor-remainder 5 -2))
52    (test '(2 -1)     (receive (floor/ -5 -2)))
53    (test 2           (floor-quotient -5 -2))
54    (test -1          (floor-remainder -5 -2))
55    (test '(2.0 -1.0) (receive (floor/ -5 -2.0)))
56    ;; From the Guile manual
57    (test 12          (floor-quotient 123 10))
58    (test 3           (floor-remainder 123 10))
59    (test '(12 3)     (receive (floor/ 123 10)))
60    (test '(-13 -7)   (receive (floor/ 123 -10)))
61    (test '(-13 7)    (receive (floor/ -123 10)))
62    (test '(12 -3)    (receive (floor/ -123 -10)))
63 
64    (test '(2 1)      (receive (truncate/ 5 2)))
65    (test 2           (truncate-quotient 5 2))
66    (test 1           (truncate-remainder 5 2))
67    (test '(-2 -1)    (receive (truncate/ -5 2)))
68    (test -2          (truncate-quotient -5 2))
69    (test -1          (truncate-remainder -5 2))
70    (test '(-2 1)     (receive (truncate/ 5 -2)))
71    (test -2          (truncate-quotient 5 -2))
72    (test 1           (truncate-remainder 5 -2))
73    (test '(2 -1)     (receive (truncate/ -5 -2)))
74    (test 2           (truncate-quotient -5 -2))
75    (test -1          (truncate-remainder -5 -2))
76    (test '(2.0 -1.0) (receive (truncate/ -5.0 -2)))
77    (test 2.0         (truncate-quotient -5.0 -2))
78    (test -1.0        (truncate-remainder -5.0 -2))
79    ;; From the Guile manual
80    (test 12          (truncate-quotient 123 10))
81    (test 3           (truncate-remainder 123 10))
82    (test '(12 3)     (receive (truncate/ 123 10)))
83    (test '(-12 3)    (receive (truncate/ 123 -10)))
84    (test '(-12 -3)   (receive (truncate/ -123 10)))
85    (test '(12 -3)    (receive (truncate/ -123 -10))))
86
87  (test-group "quotient, remainder and modulo"
88    (test 1 (modulo 13 4))
89    (test 1 (remainder 13 4))
90    (test 3 (modulo -13 4))
91    (test -1 (remainder -13 4))
92    (test -3 (modulo 13 -4))
93    (test 1 (remainder 13 -4))
94    (test -1 (modulo -13 -4))
95    (test -1 (remainder -13 -4))
96    (test -1.0 (remainder -13 -4.0)))
97
98  (test-group "square"
99    (test 1 (square 1))
100    (test 16 (square 4))
101    (test 16.0 (square 4.0))))
102
103(test-group "6.3: booleans"
104  ;; How silly...
105  (test-group "not"
106    (test #f (not #t))
107    (test #f (not 3))
108    (test #f (not (list 3)))
109    (test #t (not #f))
110    (test #f (not '()))
111    (test #f (not (list)))
112    (test #f (not 'nil))
113    (test-error (not))
114    (test-error (not 1 2)))
115 
116  (test-group "long boolean literals"
117    (test #t (read-from-string "#t"))
118    (test #f (read-from-string "#f"))
119    (test #t (read-from-string "#true"))
120    (test #f (read-from-string "#false"))
121    (test-error (read-from-string "#faux")))
122
123  (test-group "boolean=?"
124    (test #t (boolean=? #t #t))
125    (test #t (boolean=? #t #t #t #t))
126    (test #t (boolean=? #f #f))
127    (test #t (boolean=? #f #f #f #f))
128    (test #f (boolean=? #f #t))
129    (test #f (boolean=? #f #t #t #t))
130    (test #f (boolean=? #f #f #t #t))
131    (test #f (boolean=? #f #f #f #t))
132    (test #f (boolean=? #t #f #f #f))
133    (test #f (boolean=? #t #f #f #t))
134    (test #f (boolean=? #t #t #f #t))
135    (test #f (boolean=? #f #f #f #t))
136    (test #f (boolean=? #f #t #f #f))
137    (test-error (boolean=? #f))
138    (test-error (boolean=? #f 1))
139    (test-error "no shortcutting" (boolean=? #f #t 2))))
140
141(test-group "6.4: pairs and lists"
142  (test-group "pair?"
143    (test #t (pair? '(a . b)))
144    (test #t (pair? '(a b c)))
145    (test #f (pair? '()))
146    (test #f (pair? '#(a b)))
147    (test #f (pair? #f))
148    (test #f (pair? #t))
149    (test #f (pair? "some string"))
150    (test #f (pair? 123)))
151
152  (test-group "cons"
153    (test '(a) (cons 'a '()))
154    (test '((a) b c d) (cons '(a) '(b c d)))
155    (test '("a" b c) (cons "a" '(b c)))
156    (test '(a . 3) (cons 'a 3))
157    (test '((a b) . c) (cons '(a b) 'c)))
158
159  (test-group "car"
160    (test 'a (car '(a b c)))
161    (test '(a) (car '((a) b c d)))
162    (test 1 (car '(1 . 2)))
163    (test-error (car '()))
164    (test-error (car '#(1 2 3)))
165    (test-error (car "not a pair")))
166
167  (test-group "cdr"
168    (test '(b c d) (cdr '((a) b c d)))
169    (test 2 (cdr '(1 . 2)))
170    (test-error (cdr '()))
171    (test-error (cdr '#(1 2 3)))
172    (test-error (cdr "not a pair")))
173
174  (test-group "set-car!"
175    (define (f) (list 'not-a-constant-list))
176    (define (g) '(constant-list))
177    ;; Examples from the text are very incomplete and strange
178    (let ((res (f)))
179      (set-car! res 2)
180      (test 2 (car res))
181      (set-car! (f) 3)
182      (test 'not-a-constant-list (car (f))))
183    ;; XXX Should this *raise* an error?  R5RS also says this it "is an error"
184    #;(test-error (set-car! (g) 3))
185    (test-error (set-car! 'x 'y)))
186
187  (test-group "set-cdr!"
188    (define (f) (list 'not-a-constant-list))
189    (define (g) '(constant-list))
190    ;; Examples from the text are very incomplete and strange
191    (let ((res (f)))
192      (set-cdr! res 2)
193      (test 2 (cdr res))
194      (set-cdr! (f) 3)
195      (test '() (cdr (f))))
196    ;; XXX Should this *raise* an error?  R5RS also says this it "is an error"
197    #;(test-error (set-cdr! (g) 3))
198    (test-error (set-cdr! 'x 'y)))
199
200  (test-group "c..r (base)"
201    (test 'x (caar '((x) y)))
202    (test-error (caar '(x y)))
203    (test 'y (cadr '((x) y)))
204    (test-error (cadr '(x)))
205    (test '() (cdar '((x) y)))
206    (test-error (cdar '(x)))
207    (test '() (cddr '((x) y)))
208    (test-error (cddr '(x))))
209
210  ;; TODO: c..r (cxr)
211 
212  (test-group "null?"
213    (test #t (null? '()))
214    (test #t (null? (list)))
215    (test #f (null? '(a)))
216    (test #f (null? 'a))
217    (test #f (null? '#()))
218    (test #f (null? "foo")))
219
220  (test-group "list?"
221    (test #t (list? '(a b c)))
222    (test #t (list? (list 'a 'b 'c)))
223    (test #t (list? '()))
224    (test #f (list? '(a . b)))
225    (let ((x (list 'a)))
226      (set-cdr! x x)
227      (test #f (list? x)))
228    (test #f (list? 'a))
229    (test #f (list? '#()))
230    (test #f (list? "foo")))
231
232  (test-group "make-list"
233    (test-error (make-list))
234    (test '() (make-list 0))
235    (test '(#f) (make-list 1))          ; Unspecified
236   
237    (test '(#f) (make-list 1 #f))
238    (test-error (make-list 1 2 3))
239    (test '(3 3) (make-list 2 3))
240    (test '() (make-list 0 3))
241    (test-error (make-list -1 3))
242    (test-error (make-list #f 3)))
243
244  (test-group "list"
245    (test '(a 7 c) (list 'a (+ 3 4) 'c))
246    (test '() (list))
247    (test '(#f) (list #f))
248    (test '(a b c) (list 'a 'b 'c)))
249
250  (test-group "length"
251    (test 3 (length '(a b c)))
252    (test 3 (length '(a (b) (c d e))))
253    (test 0 (length '()))
254
255    (test-error (length '(x . y)))
256    (test-error (length '#(x y)))
257    (test-error (length "foo")))
258
259  (test-group "append"
260    (test '(x y) (append '(x) '(y)))
261    (test '(a b c d) (append '(a) '(b c d)))
262    (test '(a (b) (c)) (append '(a (b)) '((c))))
263    (test '(a b c . d) (append '(a b) '(c . d)))
264    (test 'a (append '() 'a))
265    (test '(a b . c) (append '(a b) 'c))
266    (test-error (append 'x '()))
267    (test-error (append '(x) 'y '())))
268
269  (test-group "reverse"
270    (test '(c b a) (reverse '(a b c)))
271    (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
272    (test '() (reverse '()))
273    (test-error (reverse '(a . b)))
274    (test-error (reverse '(a b) '(c d)))
275    (test-error (reverse 'a))
276    (test-error (reverse '#(a b c)))
277    (test-error (reverse "foo")))
278
279  (test-group "list-tail"
280    (test '(a b c d e f) (list-tail '(a b c d e f) 0))
281    (test '(d e f) (list-tail '(a b c d e f) 3))
282    (test '() (list-tail '(a b c d e f) 6))
283    (test '() (list-tail '() 0))
284    (test-error (list-tail '(a b c d e f) -1))
285    (test-error (list-tail '(a b c d e f) 7))
286    (test-error (list-tail '(a b c d e . f) 6)))
287
288  (test-group "list-ref"
289    (test 'a (list-ref '(a b c d) 0))
290    (test 'b (list-ref '(a b c d) 1))
291    (test 'c (list-ref '(a b c d) 2))
292    (test 'd (list-ref '(a b c d) 3))
293    (test-error (list-ref '(a b c d) 4))
294    (test-error (list-ref '(a b c d) -1)))
295
296  (test-group "list-set!"
297    (let ((ls (list 'one 'two 'five!)))
298      (list-set! ls 2 'three)
299      (test '(two three) (cdr ls)))
300    ;; Should be an error?
301    #;(list-set! '(0 1 2) 1 "oops")
302    (test-error (list-set! (list 1 2 3) 3 'foo)))
303
304  (test-group "mem*"
305    (test '(a b c) (memq 'a '(a b c)))
306    (test '(b c) (memq 'b '(a b c)))
307    (test #f (memq 'a '(b c d)))
308    (test #f (memq (list 'a) '(b (a) c)))
309    (test '((a) c) (member (list 'a) '(b (a) c)))
310    (test '("b" "c") (member "B" '("a" "b" "c") string-ci=?))
311    (test '(101 102) (memq 101 '(100 101 102))) ; unspecified in R7RS
312    (test '(101 102) (memv 101 '(100 101 102))))
313
314  (test-group "ass*"
315    (define e '((a 1) (b 2) (c 3)))
316    (test '(a 1) (assq 'a e))
317    (test '(b 2) (assq 'b e))
318    (test #f (assq 'd e))
319    (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))
320    (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))
321    (test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =))
322    (test '(5 7) (assq 5 '((2 3) (5 7) (11 13)))) ; unspecified in R7RS
323    (test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
324    (test-error (assq 5 '(5 6 7)))
325    (test-error (assv 5 '(5 6 7)))
326    (test-error (assoc 5 '(5 6 7))))
327
328  (test-group "list-copy"
329   (define a '(1 8 2 8)) ; a may be immutable
330   (define b (list-copy a))
331   (set-car! b 3)        ; b is mutable
332   (test '((3 8 2 8)) (list b))
333   (test '((1 8 2 8)) (list a))))
334
335(test-group "6.5: Symbols"
336  (test-group "symbol=?"
337    (test-error (symbol=?))
338    (test-error (symbol=? 'a))
339    (test-error (symbol=? 'a 1))
340    (test-error (symbol=? 'a 'b 1))
341    (test #t (symbol=? '|| '||))
342    (test #t (symbol=? '|a b| '|a b|))
343    (test #t (symbol=? 'a 'a))
344    (test #f (symbol=? 'a 'b))
345    (test #t (symbol=? 'a 'a 'a))
346    (test #f (symbol=? 'a 'a 'b))
347    (test #f (symbol=? 'a 'b 'b))
348    (test #t (symbol=? 'a 'a 'a 'a))
349    (test #f (symbol=? 'a 'a 'a 'b))
350    (test #f (symbol=? 'a 'a 'b 'b))
351    (test #f (symbol=? 'a 'b 'b 'b))))
352
353(test-group "6.6: characters"
354  (test-group "char*?"
355    (test-error "arity" (char=? #\a))
356    (test-error "type check" (char=? #\a #\a 1))
357    (test-error "no shortcutting" (char=? #\a #\b 1))
358    (test #f (char? 1))
359    (test #t (char? #\a))
360    (test #t (char=? #\a #\a))
361    (test #f (char=? #\a #\b))
362    (test #t (char=? #\a #\a #\a))
363    (test #f (char=? #\a #\b #\a))
364    (test #f (char=? #\a #\a #\b))
365    (test #t (char=? #\a #\a #\a #\a))
366    (test #f (char=? #\a #\b #\a #\a))
367    (test #f (char=? #\a #\a #\a #\b))
368    (test #t (char<? #\a #\b #\c))
369    (test #f (char<? #\a #\b #\b))
370    (test #t (char<=? #\a #\b #\b))
371    (test #f (char<=? #\a #\b #\a))
372    (test #t (char>? #\c #\b #\a))
373    (test #f (char>? #\a #\a #\a))
374    (test #t (char>=? #\b #\b #\a))
375    (test #f (char>=? #\b #\a #\b))))
376
377(test-group "6.7: strings"
378
379  (test-group "string*?"
380    (test-error "arity" (string=? "a"))
381    (test-error "type check" (string=? "a" "a" 1))
382    (test-error "no shortcutting" (string=? "a" "b" 1))
383    (test #f (string? 1))
384    (test #t (string? "a"))
385    (test #t (string=? "a" "a"))
386    (test #f (string=? "a" "b"))
387    (test #t (string=? "a" "a" "a"))
388    (test #f (string=? "a" "b" "a"))
389    (test #f (string=? "a" "a" "b"))
390    (test #t (string=? "a" "a" "a" "a"))
391    (test #f (string=? "a" "b" "a" "a"))
392    (test #f (string=? "a" "a" "a" "b"))
393    (test #t (string<? "a" "b" "c"))
394    (test #f (string<? "a" "b" "b"))
395    (test #t (string<=? "a" "b" "b"))
396    (test #f (string<=? "a" "b" "a"))
397    (test #t (string>? "c" "b" "a"))
398    (test #f (string>? "c" "b" "b"))
399    (test #t (string>=? "b" "b" "a"))
400    (test #f (string>=? "b" "a" "b")))
401
402  (test-group "string->list"
403    (test-error (string->list "" 1))
404    (test-error (string->list "a" 1 2))
405    (test '(#\a) (string->list "a"))
406    (test '() (string->list "a" 1))
407    (test '(#\b) (string->list "abc" 1 2))
408    (test '() (string->list "abc" 2 2)))
409 
410  (test-group "string->vector"
411    (test-error (string->vector "" 1))
412    (test-error (string->vector "a" 0 2))
413    (test #(#\a) (string->vector "a"))
414    (test #() (string->vector "a" 1 1))
415    (test #(#\b) (string->vector "abc" 1 2))
416    (test #() (string->vector "abc" 2 2)))
417
418  (test-group "vector->string"
419    (test-error (vector->string #() 1))
420    (test-error (vector->string #(1)))
421    (test-error (vector->string #(#\a) 0 2))
422    (test "a" (vector->string #(#\a)))
423    (test "" (vector->string #(#\a) 1 1))
424    (test "b" (vector->string #(#\a #\b #\c) 1 2))
425    (test "" (vector->string #(#\a #\b #\c) 2 2))))
426
427(test-group "6.8: vectors"
428
429  (test-group "vector-copy"
430    (test-error (vector-copy ""))
431    (test-error (vector-copy #() #()))
432    (test-error (vector-copy #() 1))
433    (test-error (vector-copy #(0) -1))
434    (test-error (vector-copy #(0) 0 2))
435    (test #() (vector-copy #()))
436    (test #(0 1 2) (vector-copy #(0 1 2)))
437    (test #(1 2) (vector-copy #(0 1 2) 1))
438    (test #(1) (vector-copy #(0 1 2) 1 2))
439    (test #() (vector-copy #(0 1 2) 1 1)))
440
441  (test-group "vector-copy!"
442    (test-error (vector-copy! ""))
443    (test-error (vector-copy! #(0) 0 ""))
444    (test-error (vector-copy! #() #() 0))
445    (test-error (vector-copy! #() 0 #(0)))
446    (test-error (vector-copy! #(0) 1 #(0)))
447    (test-error (vector-copy! #(0) 1 #(0) 0))
448    (test-error (vector-copy! #(0) 0 #(0) 0 2))
449    (test-error (vector-copy! #(0) 0 #(0 1) 1 0))
450    (test-assert (vector-copy! #() 0 #()))
451    (let ((t #(0 1 2))
452          (f #(3 4 5 6)))
453      (vector-copy! t 0 f 1 1)
454      (test "(vector-copy! t 1 f 1 1)" #(0 1 2) t)
455      (vector-copy! t 0 f 0 1)
456      (test "(vector-copy! t 0 f 0 1)" #(3 1 2) t)
457      (vector-copy! t 0 f 1 3)
458      (test "(vector-copy! t 0 f 1 3)" #(4 5 2) t)
459      (vector-copy! t 1 f 2)
460      (test "(vector-copy! t 1 f 1)" #(4 5 6) t)
461      (vector-copy! t 0 f 1)
462      (test "(vector-copy! t 0 f)" #(4 5 6) t)))
463
464  (test-group "vector-append"
465    (test-error (vector-append ""))
466    (test-error (vector-append #() 1))
467    (test #() (vector-append))
468    (test #(0) (vector-append #(0)))
469    (test #() (vector-append #() #()))
470    (test #(0 1) (vector-append #(0) #(1)))
471    (test #(0 1 2 3 4 5) (vector-append #(0 1) #(2 3) #(4 5))))
472
473  (test-group "vector->list"
474    (test-error (vector->list ""))
475    (test-error (vector->list #() 1))
476    (test '() (vector->list #()))
477    (test '(0 1 2) (vector->list #(0 1 2)))
478    (test '(1 2) (vector->list #(0 1 2) 1))
479    (test '(1) (vector->list #(0 1 2) 1 2))
480    (test '() (vector->list #(0 1 2) 2 2))))
481
482(test-group "6.9: bytevectors"
483
484  (test-group "bytevector-copy"
485    (test-error (bytevector-copy ""))
486    (test-error (bytevector-copy #u8() #u8()))
487    (test-error (bytevector-copy #u8() 1))
488    (test-error (bytevector-copy #u8(0) -1))
489    (test-error (bytevector-copy #u8(0) 0 2))
490    (test #u8() (bytevector-copy #u8()))
491    (test #u8(0 1 2) (bytevector-copy #u8(0 1 2)))
492    (test #u8(1 2) (bytevector-copy #u8(0 1 2) 1))
493    (test #u8(1) (bytevector-copy #u8(0 1 2) 1 2))
494    (test #u8() (bytevector-copy #u8(0 1 2) 1 1)))
495
496  (test-group "bytevector-copy!"
497    (test-error (bytevector-copy! ""))
498    (test-error (bytevector-copy! #u8(0) 0 ""))
499    (test-error (bytevector-copy! #u8() #u8() 0))
500    (test-error (bytevector-copy! #u8() 0 #u8(0)))
501    (test-error (bytevector-copy! #u8(0) 1 #u8(0)))
502    (test-error (bytevector-copy! #u8(0) 1 #u8(0) 0))
503    (test-error (bytevector-copy! #u8(0) 0 #u8(0) 0 2))
504    (test-error (bytevector-copy! #u8(0) 0 #u8(0 1) 1 0))
505    (test-assert (bytevector-copy! #u8() 0 #u8()))
506    (let ((t #u8(0 1 2))
507          (f #u8(3 4 5 6)))
508      (bytevector-copy! t 0 f 1 1)
509      (test "(bytevector-copy! t 1 f 1 1)" #u8(0 1 2) t)
510      (bytevector-copy! t 0 f 0 1)
511      (test "(bytevector-copy! t 0 f 0 1)" #u8(3 1 2) t)
512      (bytevector-copy! t 0 f 1 3)
513      (test "(bytevector-copy! t 0 f 1 3)" #u8(4 5 2) t)
514      (bytevector-copy! t 1 f 2)
515      (test "(bytevector-copy! t 1 f 1)" #u8(4 5 6) t)
516      (bytevector-copy! t 0 f 1)
517      (test "(bytevector-copy! t 0 f)" #u8(4 5 6) t)))
518
519  (test-group "bytevector-append"
520    (test-error (bytevector-append #u8() 1))
521    (test #u8() (bytevector-append))
522    (test #u8(0) (bytevector-append #u8(0)))
523    (test #u8() (bytevector-append #u8() #u8()))
524    (test #u8(0 1) (bytevector-append #u8(0) #u8(1)))
525    (test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1) #u8(2 3) #u8(4 5)))))
526
527(test-group "6.10: Control features"
528
529  (define (1st . a) (first a))
530  (define (2nd . a) (second a))
531  (define (acc proc f . rest) ; accumulate results of `f`
532    (let ((a '()))
533      (apply proc (lambda args (set! a (cons (apply f args) a))) rest)
534      (reverse a)))
535
536  (define char-add1
537    (compose integer->char add1 char->integer))
538
539  (test-group "string-map"
540    (test-error (string-map "abc"))
541    (test-error (string-map values))
542    (test-error (string-map values '(1 2 3)))
543    (test-error (string-map (constantly 1) "abc"))
544    (test "" (string-map values ""))
545    (test "abc" (string-map values "abc"))
546    (test "aaa" (string-map (constantly #\a) "abc"))
547    (test "bcd" (string-map char-add1 "abc"))
548    (test "abc" (string-map 1st "abc" "123"))
549    (test "123" (string-map 2nd "abc" "123"))
550    (test "abc" (string-map 1st "abc" "123456"))
551    (test "123" (string-map 2nd "abc" "123456")))
552
553  (test-group "string-for-each"
554    (test-error (string-for-each "abc"))
555    (test-error (string-for-each values))
556    (test-error (string-for-each values '(1 2 3)))
557    (test '() (acc string-for-each values ""))
558    (test '(#\a #\b #\c) (acc string-for-each values "abc"))
559    (test '(#\b #\c #\d) (acc string-for-each char-add1 "abc"))
560    (test '((#\a #\1) (#\b #\2) (#\c #\3)) (acc string-for-each list "abc" "123"))
561    (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123"))
562    (test '(#\a #\b #\c) (acc string-for-each 1st "abc" "123456"))
563    (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123456")))
564
565  (test-group "vector-map"
566    (test-error (vector-map #(1 2 3)))
567    (test-error (vector-map values))
568    (test-error (vector-map values '(1 2 3)))
569    (test #() (vector-map values #()))
570    (test #(1 2 3) (vector-map values #(1 2 3)))
571    (test #(1 1 1) (vector-map (constantly 1) #(1 2 3)))
572    (test #(2 3 4) (vector-map add1 #(1 2 3)))
573    (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6)))
574    (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6)))
575    (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6 7 8 9)))
576    (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6 7 8 9))))
577
578  (test-group "vector-for-each"
579    (test-error (vector-for-each #(1 2 3)))
580    (test-error (vector-for-each values))
581    (test-error (vector-for-each values '(1 2 3)))
582    (test '() (acc vector-for-each values #()))
583    (test '(1 2 3) (acc vector-for-each values #(1 2 3)))
584    (test '(2 3 4) (acc vector-for-each add1 #(1 2 3)))
585    (test '((1 4) (2 5) (3 6)) (acc vector-for-each list #(1 2 3) #(4 5 6)))
586    (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6)))
587    (test '(1 2 3) (acc vector-for-each 1st #(1 2 3) #(4 5 6 7 8 9)))
588    (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6 7 8 9)))))
589
590(test-group "6.13: Input"
591  (test-assert "read-string returns eof-object for empty string"
592               (eof-object? (with-input-from-string "" (lambda () (read-string 1)))))
593  (test-assert "read-bytevector returns eof-object for empty string"
594               (eof-object? (with-input-from-string "" (lambda () (read-bytevector 1))))))
595
596(define-syntax catch
597  (syntax-rules ()
598    ((_ . body) (handle-exceptions e e . body))))
599
600(test-group "exceptions"
601  (test "with-exception-handler (escape)"
602        'exception
603        (call-with-current-continuation
604         (lambda (k)
605           (with-exception-handler
606            (lambda (e) (k 'exception))
607            (lambda () (+ 1 (raise 'an-error)))))))
608  (test-error "with-exception-handler (return)"
609              (with-exception-handler
610               (lambda (e) 'ignore)
611               (lambda () (+ 1 (raise 'an-error)))))
612  (test-error "with-exception-handler (raise)"
613              (with-exception-handler
614               (lambda (e) (raise 'another-error))
615               (lambda () (+ 1 (raise 'an-error)))))
616  (test "with-exception-handler (raise-continuable)"
617        '("should be a number" 65)
618        (let* ((exception-object #f)
619               (return-value 
620                (with-exception-handler
621                 (lambda (e) (set! exception-object e) 42)
622                 (lambda () (+ (raise-continuable "should be a number") 23)))))
623          (list exception-object return-value)))
624  (test "error-object? (#f)" #f (error-object? 'no))
625  (test "error-object? (#t)" #t (error-object? (catch (car '()))))
626  (test "error-object-message" "fubar" (error-object-message (catch (error "fubar"))))
627  (test "error-object-irritants" '(42) (error-object-irritants (catch (error "fubar" 42))))
628  (test "read-error? (#f)" #f (read-error? (catch (car '()))))
629  (test "read-error? (#t)" #t (read-error? (catch (read-from-string ")"))))
630  (test "file-error? (#f)" #f (file-error? (catch (car '()))))
631  (test "file-error? (#t)" #t (file-error? (catch (open-input-file "foo"))))
632  (test-error "guard (no match)"
633              (guard (condition ((assq 'c condition))) (raise '((a . 42)))))
634  (test "guard (match)"
635        '(b . 23)
636        (guard (condition ((assq 'b condition))) (raise '((b . 23)))))
637  (test "guard (=>)"
638        42
639        (guard (condition ((assq 'a condition) => cdr)) (raise '((a . 42)))))
640  (test "guard (multiple)"
641        '(b . 23)
642        (guard (condition
643                ((assq 'a condition) => cdr)
644                ((assq 'b condition)))
645               (raise '((b . 23))))))
646
647;; call-with-port is not supposed to close its port when leaving the
648;; dynamic extent, only on normal return.
649;;
650;; XXX TODO: Rewrite in terms of SRFI-6 string port interface, so
651;; no call-with-*-string, but use get-output-string and such!
652;; Do this when it's clear how to re-export Chicken stuff.
653(test-group "string ports"
654  (receive (jump-back? jump!)
655      (call/cc (lambda (k) (values #f k)))
656    (when jump-back? (jump! (void)))
657    (let ((string (call-with-output-string
658                   (lambda (the-string-port)
659                     (receive (one two three)
660                         (call-with-port the-string-port
661                          (lambda (p)
662                            (display "foo" p)
663                            ;; Leave the dynamic extent momentarily;
664                            ;; jump! will immediately return with #t.
665                            (call/cc (lambda (k) (jump! #t k)))
666                            (test-assert "Port is still open after excursion"
667                                         (output-port-open? the-string-port))
668                            (display "bar" p)
669                            (values 1 2 3)))
670                       (test "call-with-port returns all values yielded by proc"
671                             '(1 2 3)
672                             (list one two three)))
673                     (test-assert "call-with-port closes the port on normal return"
674                                  (not (output-port-open? the-string-port)))
675                     (test-assert "It's ok to close output ports that are closed"
676                                  (close-port the-string-port))
677                     (test-error "input-port-open? fails on output ports"
678                                 (input-port-open? the-string-port))))))
679      (test "call-with-port passes the port correctly and allows temporary escapes"
680            "foobar" string)))
681
682  (call-with-input-string "foo"
683    (lambda (the-string-port)
684      (test-error "output-port-open? fails on input ports"
685                  (output-port-open? the-string-port))
686      (test-assert "Initially, string port is open"
687                   (input-port-open? the-string-port))
688      (test "Reading from string delivers the data"
689            'foo (read the-string-port))
690      (test "After reading all, we get the eof-object"
691            (eof-object) (read the-string-port))
692      (test-assert "Port is still open after all reads"
693                   (input-port-open? the-string-port))
694      (close-port the-string-port)
695      (test-assert "Port is no longer open after closing it"
696                   (not (input-port-open? the-string-port)))
697      (test-assert "It's ok to close input ports that are already closed"
698                   (close-port the-string-port)))))
699
700;; This is for later. We can't define it inside a group because that
701;; would make it locally scoped (as a letrec rewrite), which breaks
702;; the syntax-rules underscore tests.  Very subtle (and annoying), this!
703(define (_) 'underscore-procedure)
704(define ___ 'triple-underscore-literal)
705
706(test-group "syntax-rules"
707  (test "let-syntax w/ basic syntax-rules"
708        100
709        (let-syntax ((foo (syntax-rules ()
710                            ((_ x form)
711                             (let ((tmp x))
712                               (if (number? tmp)
713                                   form
714                                   (error "not a number" tmp)))))))
715          (foo 2 100)))
716  (let-syntax ((foo (syntax-rules ()
717                      ((_ #(a ...)) (list a ...)))))
718    (test "Basic matching of vectors"
719          '(1 2 3) (foo #(1 2 3))))
720  ;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
721  (let-syntax ((foo (syntax-rules ()
722                      ((_ (a b) ...)
723                       (list 'first '(a b) ...))
724                      ((_ a ...)
725                       (list 'second '(a) ...)))))
726    (test "Basic ellipsis match"
727          '(first (1 2) (3 4) (5 6)) (foo (1 2) (3 4) (5 6)))
728    (test "Ellipsis match of length 1 does not match length 2"
729          '(second (1)) (foo 1))
730    (test "Ellipsis match of lists with mismatched lengths (used to fail)"
731          '(second ((1 2)) ((3)) ((5 6))) (foo (1 2) (3) (5 6))))
732
733  (test "letrec-syntax"
734        34
735        (letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))
736                        (bar (syntax-rules () ((_ x) (+ x 1)))))
737          (foo 33)))
738  (test "Basic hygienic rename of syntactic keywords"
739        'now
740        (let-syntax ((when (syntax-rules ()
741                             ((when test stmt1 stmt2 ...)
742                              (if test
743                                  (begin stmt1
744                                         stmt2 ...))))))
745          (let ((if #t))
746            (when if (set! if 'now))
747            if)))
748  (test "Basic hygienic rename of shadowed outer let"
749        'outer
750        (let ((x 'outer))
751          (let-syntax ((m (syntax-rules () ((m) x))))
752            (let ((x 'inner))
753              (m)))))
754  (test "Simple recursive letrec expansion"
755        7
756        (letrec-syntax
757            ((my-or (syntax-rules ()
758                      ((my-or) #f)
759                      ((my-or e) e)
760                      ((my-or e1 e2 ...)
761                       (let ((temp e1))
762                         (if temp
763                             temp
764                             (my-or e2 ...)))))))
765          (let ((x #f)
766                (y 7)
767                (temp 8)
768                (let odd?)
769                (if even?))
770            (my-or x
771                   (let temp)
772                   (if y)
773                   y))))
774  ;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"
775  (let ((a 1))
776    (letrec-syntax
777        ((foo (syntax-rules ()
778                ((_ b)
779                 (bar a b))))
780         (bar (syntax-rules ()
781                ((_ c d)
782                 (cons c (let ((c 3))
783                           (list d c 'c)))))))
784      (let ((a 2))
785        (test "Al* Petrofsky torture test" '(1 2 3 a) (foo a)))))
786  (let-syntax
787      ((foo (syntax-rules ()
788              ((_)
789               '#(b)))))
790    (test "Quoted symbols inside vectors are stripped of syntactic info"
791          '#(b) (foo)))
792  (let-syntax ((kw (syntax-rules (baz)
793                     ((_ baz) "baz")
794                     ((_ any) "no baz"))))
795    (test "syntax-rules keywords match" "baz" (kw baz))
796    (test "syntax-rules keywords no match" "no baz" (kw xxx))
797    (let ((baz 100))
798      (test "keyword loses meaning if shadowed" "no baz" (kw baz))))
799  (test "keyword also loses meaning for builtins (from R7RS section 4.3.2)"
800        'ok
801        (let ((=> #f))
802          (cond (#t => 'ok))))
803  (test "Nested identifier shadowing works correctly"
804        '(3 4)
805        (let ((foo 3))
806          (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))
807            (let ((foo 4))
808              (bar foo)))))
809  (let-syntax ((c (syntax-rules ()
810                    ((_)
811                     (let ((x 10))
812                       (let-syntax ((z (syntax-rules ()
813                                         ((_) (quote x)))))
814                         (z))))))
815               (c2 (syntax-rules ()
816                     ((_)
817                      (let ((x 10))
818                        (let-syntax
819                            ((z (syntax-rules ()
820                                  ((_) (let-syntax
821                                           ((w (syntax-rules ()
822                                                 ((_) (quote x)))))
823                                         (w))))))
824                          (z)))))))
825    ;; Reported by Matthew Flatt
826    (test "strip-syntax cuts across three levels of syntax"
827          "x" (symbol->string (c)))
828    (test "strip-syntax cuts across four levels of syntax"
829          "x" (symbol->string (c2))))
830  (let-syntax ((foo (syntax-rules
831                        ___ () 
832                        ((_ vals ___) (list '... vals ___)))))
833    (test "Alternative ellipsis (from SRFI-46)"
834          '(... 1 2 3) (foo 1 2 3)))
835  (let-syntax ((let-alias (syntax-rules
836                              ___ ()
837                              ((_ new old code ___)
838                               (let-syntax
839                                   ((new
840                                     (syntax-rules ()
841                                       ((_ args ...) (old args ...)))))
842                                 code ___)))))
843    (let-alias inc (lambda (x) (+ 1 x))
844               (test "Ellipsis rules are reset in new macro expansion phase"
845                     3 (inc 2))))
846  (let-syntax ((foo (syntax-rules ()
847                      ((_ (a ... b) ... (c d))
848                       (list (list (list a ...) ... b ...) c d))
849                      ((_ #(a ... b) ... #(c d) #(e f))
850                       (list (list (vector a ...) ... b ...) c d e f))
851                      ((_ #(a ... b) ... #(c d))
852                       (list (list (vector a ...) ... b ...) c d)))))
853    (test-group "rest patterns after ellipsis (SRFI-46 smoke test)"
854      (test '(() 1 2) (foo (1 2)))
855      (test '(((1) 2) 3 4) (foo (1 2) (3 4)))
856      (test '(((1 2) (4) 3 5) 6 7)
857            (foo (1 2 3) (4 5) (6 7)))
858      (test '(() 1 2)
859            (foo #(1 2)))
860      (test '((#() 1) 2 3)
861            (foo #(1) #(2 3)))
862      (test '((#(1 2) 3) 4 5)
863            (foo #(1 2 3) #(4 5)))
864      (test '((#(1 2) 3) 4 5 6 7)
865            (foo #(1 2 3) #(4 5) #(6 7)))
866      (test '(() 1 2 3 4)
867            (foo #(1 2) #(3 4)))
868      (test '((#(1) 2) 3 4 5 6)
869            (foo #(1 2) #(3 4) #(5 6)))
870      (test '((#(1 2) #(4) 3 5) 6 7 8 9)
871            (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))))
872  (let-syntax ((foo (syntax-rules ()
873                      ((_ #((a) ...)) (list a ...)))))
874    (test "Bug discovered during implementation of rest patterns"
875          '(1)
876          (foo #((1)))))
877  ;; R7RS: (<ellipsis> <template>) is like <template>, ignoring
878  ;; occurrances of <ellipsis> inside the template.
879  (let-syntax ((be-like-begin
880                (syntax-rules ()
881                  ((be-like-begin name)
882                   (define-syntax name
883                     (syntax-rules ()
884                       ((name expr (... ...))
885                        (begin expr (... ...)))))))))
886    (be-like-begin sequence)
887    (test "be-like-begin from R7RS 4.3.2 (nested ellipsis are not expanded)"
888          4 (sequence 1 2 3 4)))
889  (let-syntax ((ignore-underscores
890                (syntax-rules ()
891                  ((_ _ _ _) (_)))))
892    (test "underscores are ignored in patterns"
893          'underscore-procedure (ignore-underscores _ b c)))
894
895  (test-group "undefined behaviours: mixing keywords, ellipsis and underscores"
896    (test-group "underscore as keyword literal"
897      (define-syntax match-literal-underscores ; for eval
898        (syntax-rules (_)
899          ((x a _ c) (_))
900          ((x _ b c) 1)))
901      (test-error "Missing literal underscore keyword causes syntax-error"
902                  (eval '(match-literal-underscores d e f)))
903      (test "Literal underscore matches"
904            1 (match-literal-underscores _ h i))
905      (test "Literal underscore matches even if it refers to toplevel binding"
906            'underscore-procedure (match-literal-underscores g _ i)))
907   
908    (test-group "underscore as ellipsis"
909     ;; It's undefined what this should do.  Logically, it should be
910     ;; possible to bind _ as an ellipsis identifier.
911     (define-syntax match-ellipsis-underscores ; for eval
912       (syntax-rules _ () ((x a _ c) (list a _ c))))
913     (test-error "No rule matching if prefix is omitted"
914                 (eval '(match-ellipsis-underscores)))
915     (test "Only prefix is supplied"
916           '(1) (match-ellipsis-underscores 1))
917     (test "Ellipsis does its work if multiple arguments given"
918           '(1 2 3 4 5 6) (match-ellipsis-underscores 1 2 3 4 5 6)))
919
920    (test-group "underscore as ellipsis mixed with underscore literal"
921      ;; Even more undefined behaviour: mixing literals and ellipsis identifiers
922      ;; Currently, ellipsis identifiers have precedence over the other two.
923      (define-syntax match-ellipsis-and-literals-underscores ; for eval
924        (syntax-rules _ (_) ((x a _ c) (list a _ c))))
925      (test-error "No rule matching if prefix is omitted"
926                  (eval '(match-ellipsis-and-literals-underscores)))
927      (test '(1) (match-ellipsis-and-literals-underscores 1))
928      (test '(1 2 3) (match-ellipsis-and-literals-underscores 1 2 3))
929      (test '(1 2 3 4 5 6) (match-ellipsis-and-literals-underscores 1 2 3 4 5 6)))
930
931    (test-group "\"custom\" ellipsis and literal of the same identifier"
932      ;; This is similar to the above, but maybe a little simpler because
933      ;; it does not use reserved names:
934      (define-syntax match-ellipsis-literals
935        (syntax-rules ___ (___)
936                      ((_ x ___) (list x ___))))
937      (test "Ellipsis as literals"
938            '(1) (match-ellipsis-literals 1))
939      (test "Ellipsis as literals multiple args"
940            '(1 2) (match-ellipsis-literals 1 2))
941      (test "Toplevel binding of the same name as ellipsis"
942            '(1 triple-underscore-literal) (match-ellipsis-literals 1 ___))))
943
944  (letrec-syntax ((usetmp
945                   (syntax-rules ()
946                     ((_ var) 
947                      (list var))))
948                  (withtmp
949                   (syntax-rules ()
950                     ((_ val exp)
951                      (let ((tmp val))
952                        (exp tmp))))))
953    (test "Passing a macro as argument to macro"
954          '(99)
955          (withtmp 99 usetmp)))
956
957  ;; renaming of keyword argument (#277)
958  (let-syntax ((let-hello-proc
959                (syntax-rules ()
960                  ((_ procname code ...)
961                   (let ((procname (lambda (#!key (who "world"))
962                                     (string-append "hello, " who))))
963                     code ...)))))
964    (let-hello-proc bar
965         ;; This is not R7RS, but R7RS should not interfere with other
966         ;; CHICKEN features!
967         (test "DSSSL keyword arguments aren't renamed (not R7RS)"
968               "hello, XXX" (bar who: "XXX")))))
969
970(test-group "define-library"
971  (test-assert "R7RS libraries use the numbers extension"
972               (define-library (foo)
973                 (import (scheme base))
974                 (begin (eq? numbers#+ +)))))
975
976(test-end "r7rs tests")
977
978(test-exit)
Note: See TracBrowser for help on using the repository browser.