source: project/release/5/r7rs/tags/1.0.2/tests/run.scm @ 38750

Last change on this file since 38750 was 38750, checked in by felix winkelmann, 3 months ago

Omit C4-only module check, add cond-expand tests

(Patch provided by wasamasa)

Dropped some unnecessary compile-time conditionals.

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