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

Last change on this file since 31045 was 31045, checked in by evhan, 6 years ago

r7rs/read: #![no-]fold-case, check read's argument type

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