~ chicken-r7rs (master) /tests/run.scm
Trap1(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))1314;; XXX: This seems to be necessary in order to get the syntax-rules15;; from r7rs rather than the built-in CHICKEN one. I'm not sure if16;; that's correct or not...17(import-for-syntax (r7rs))1819(define (read-from-string s)20 (with-input-from-string s read))2122(test-begin "r7rs tests")2324(test-group "2.1: Identifiers"25 (test "#!(no-)fold-case"26 '(FOO mooh qux blah foo BAR)27 (append28 (with-input-from-string29 "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 (append33 (with-input-from-string "FOO #!fold-case bar BAZ" read-list)34 (with-input-from-string "downcased UPCASED" read-list))))3536(test-group "4.1.7: Inclusion"37 (test-group "include"38 (test "multiple filenames"39 "abcabc"40 (with-output-to-string41 (lambda () (include "include.scm" "include.scm"))))42 (test-error "case sensitivity"43 (with-output-to-string44 (lambda () (include "include-ci.scm")))))45 (test-group "include-ci"46 (test "multiple filenames"47 "abcabc"48 (with-output-to-string49 (lambda () (include-ci "include.scm" "include.scm"))))50 (test "case sensitivity"51 "abc"52 (with-output-to-string53 (lambda () (include-ci "include-ci.scm"))))))5455#+full-numeric-tower56(test-group "6.2.6: numerical operations"57 (test-group "floor/...truncate-remainder"58 (test '(2 1) (receive (floor/ 5 2)))59 (test 2 (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 '(-3 -1) (receive (floor/ 5 -2)))65 (test -3 (floor-quotient 5 -2))66 (test -1 (floor-remainder 5 -2))67 (test '(2 -1) (receive (floor/ -5 -2)))68 (test 2 (floor-quotient -5 -2))69 (test -1 (floor-remainder -5 -2))70 (test '(2.0 -1.0) (receive (floor/ -5 -2.0)))71 ;; From the Guile manual72 (test 12 (floor-quotient 123 10))73 (test 3 (floor-remainder 123 10))74 (test '(12 3) (receive (floor/ 123 10)))75 (test '(-13 -7) (receive (floor/ 123 -10)))76 (test '(-13 7) (receive (floor/ -123 10)))77 (test '(12 -3) (receive (floor/ -123 -10)))7879 (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 -1) (receive (truncate/ -5 -2)))89 (test 2 (truncate-quotient -5 -2))90 (test -1 (truncate-remainder -5 -2))91 (test '(2.0 -1.0) (receive (truncate/ -5.0 -2)))92 (test 2.0 (truncate-quotient -5.0 -2))93 (test -1.0 (truncate-remainder -5.0 -2))94 ;; From the Guile manual95 (test 12 (truncate-quotient 123 10))96 (test 3 (truncate-remainder 123 10))97 (test '(12 3) (receive (truncate/ 123 10)))98 (test '(-12 3) (receive (truncate/ 123 -10)))99 (test '(-12 -3) (receive (truncate/ -123 10)))100 (test '(12 -3) (receive (truncate/ -123 -10))))101102 (test-group "quotient, remainder and modulo"103 (test 1 (modulo 13 4))104 (test 1 (remainder 13 4))105 (test 3 (modulo -13 4))106 (test -1 (remainder -13 4))107 (test -3 (modulo 13 -4))108 (test 1 (remainder 13 -4))109 (test -1 (modulo -13 -4))110 (test -1 (remainder -13 -4))111 (test -1.0 (remainder -13 -4.0)))112113 (test-group "square"114 (test 1 (square 1))115 (test 16 (square 4))116 (test 16.0 (square 4.0))))117118(test-group "6.3: booleans"119 ;; How silly...120 (test-group "not"121 (test #f (not #t))122 (test #f (not 3))123 (test #f (not (list 3)))124 (test #t (not #f))125 (test #f (not '()))126 (test #f (not (list)))127 (test #f (not 'nil))128 (test-error (not))129 (test-error (not 1 2)))130131 (test-group "long boolean literals"132 (test #t (read-from-string "#t"))133 (test #f (read-from-string "#f"))134 (test #t (read-from-string "#true"))135 (test #f (read-from-string "#false"))136 (test-error (read-from-string "#faux")))137138 (test-group "boolean=?"139 (test #t (boolean=? #t #t))140 (test #t (boolean=? #t #t #t #t))141 (test #t (boolean=? #f #f))142 (test #t (boolean=? #f #f #f #f))143 (test #f (boolean=? #f #t))144 (test #f (boolean=? #f #t #t #t))145 (test #f (boolean=? #f #f #t #t))146 (test #f (boolean=? #f #f #f #t))147 (test #f (boolean=? #t #f #f #f))148 (test #f (boolean=? #t #f #f #t))149 (test #f (boolean=? #t #t #f #t))150 (test #f (boolean=? #f #f #f #t))151 (test #f (boolean=? #f #t #f #f))152 (test-error (boolean=? #f))153 (test-error (boolean=? #f 1))154 (test-error "no shortcutting" (boolean=? #f #t 2))))155156(test-group "6.4: pairs and lists"157 (test-group "pair?"158 (test #t (pair? '(a . b)))159 (test #t (pair? '(a b c)))160 (test #f (pair? '()))161 (test #f (pair? '#(a b)))162 (test #f (pair? #f))163 (test #f (pair? #t))164 (test #f (pair? "some string"))165 (test #f (pair? 123)))166167 (test-group "cons"168 (test '(a) (cons 'a '()))169 (test '((a) b c d) (cons '(a) '(b c d)))170 (test '("a" b c) (cons "a" '(b c)))171 (test '(a . 3) (cons 'a 3))172 (test '((a b) . c) (cons '(a b) 'c)))173174 (test-group "car"175 (test 'a (car '(a b c)))176 (test '(a) (car '((a) b c d)))177 (test 1 (car '(1 . 2)))178 (test-error (car '()))179 (test-error (car '#(1 2 3)))180 (test-error (car "not a pair")))181182 (test-group "cdr"183 (test '(b c d) (cdr '((a) b c d)))184 (test 2 (cdr '(1 . 2)))185 (test-error (cdr '()))186 (test-error (cdr '#(1 2 3)))187 (test-error (cdr "not a pair")))188189 (test-group "set-car!"190 (define (f) (list 'not-a-constant-list))191 (define (g) '(constant-list))192 ;; Examples from the text are very incomplete and strange193 (let ((res (f)))194 (set-car! res 2)195 (test 2 (car res))196 (set-car! (f) 3)197 (test 'not-a-constant-list (car (f))))198 ;; XXX Should this *raise* an error? R5RS also says this it "is an error"199 #;(test-error (set-car! (g) 3))200 (test-error (set-car! 'x 'y)))201202 (test-group "set-cdr!"203 (define (f) (list 'not-a-constant-list))204 (define (g) '(constant-list))205 ;; Examples from the text are very incomplete and strange206 (let ((res (f)))207 (set-cdr! res 2)208 (test 2 (cdr res))209 (set-cdr! (f) 3)210 (test '() (cdr (f))))211 ;; XXX Should this *raise* an error? R5RS also says this it "is an error"212 #;(test-error (set-cdr! (g) 3))213 (test-error (set-cdr! 'x 'y)))214215 (test-group "c..r (base)"216 (test 'x (caar '((x) y)))217 (test-error (caar '(x y)))218 (test 'y (cadr '((x) y)))219 (test-error (cadr '(x)))220 (test '() (cdar '((x) y)))221 (test-error (cdar '(x)))222 (test '() (cddr '((x) y)))223 (test-error (cddr '(x))))224225 ;; TODO: c..r (cxr)226227 (test-group "null?"228 (test #t (null? '()))229 (test #t (null? (list)))230 (test #f (null? '(a)))231 (test #f (null? 'a))232 (test #f (null? '#()))233 (test #f (null? "foo")))234235 (test-group "list?"236 (test #t (list? '(a b c)))237 (test #t (list? (list 'a 'b 'c)))238 (test #t (list? '()))239 (test #f (list? '(a . b)))240 (let ((x (list 'a)))241 (set-cdr! x x)242 (test #f (list? x)))243 (test #f (list? 'a))244 (test #f (list? '#()))245 (test #f (list? "foo")))246247 (test-group "make-list"248 (test-error (make-list))249 (test '() (make-list 0))250 (test '(#f) (make-list 1)) ; Unspecified251252 (test '(#f) (make-list 1 #f))253 (test-error (make-list 1 2 3))254 (test '(3 3) (make-list 2 3))255 (test '() (make-list 0 3))256 (test-error (make-list -1 3))257 (test-error (make-list #f 3)))258259 (test-group "list"260 (test '(a 7 c) (list 'a (+ 3 4) 'c))261 (test '() (list))262 (test '(#f) (list #f))263 (test '(a b c) (list 'a 'b 'c)))264265 (test-group "length"266 (test 3 (length '(a b c)))267 (test 3 (length '(a (b) (c d e))))268 (test 0 (length '()))269270 (test-error (length '(x . y)))271 (test-error (length '#(x y)))272 (test-error (length "foo")))273274 (test-group "append"275 (test '(x y) (append '(x) '(y)))276 (test '(a b c d) (append '(a) '(b c d)))277 (test '(a (b) (c)) (append '(a (b)) '((c))))278 (test '(a b c . d) (append '(a b) '(c . d)))279 (test 'a (append '() 'a))280 (test '(a b . c) (append '(a b) 'c))281 (test-error (append 'x '()))282 (test-error (append '(x) 'y '())))283284 (test-group "reverse"285 (test '(c b a) (reverse '(a b c)))286 (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))287 (test '() (reverse '()))288 (test-error (reverse '(a . b)))289 (test-error (reverse '(a b) '(c d)))290 (test-error (reverse 'a))291 (test-error (reverse '#(a b c)))292 (test-error (reverse "foo")))293294 (test-group "list-tail"295 (test '(a b c d e f) (list-tail '(a b c d e f) 0))296 (test '(d e f) (list-tail '(a b c d e f) 3))297 (test '() (list-tail '(a b c d e f) 6))298 (test '() (list-tail '() 0))299 (test-error (list-tail '(a b c d e f) -1))300 (test-error (list-tail '(a b c d e f) 7))301 (test-error (list-tail '(a b c d e . f) 6)))302303 (test-group "list-ref"304 (test 'a (list-ref '(a b c d) 0))305 (test 'b (list-ref '(a b c d) 1))306 (test 'c (list-ref '(a b c d) 2))307 (test 'd (list-ref '(a b c d) 3))308 (test-error (list-ref '(a b c d) 4))309 (test-error (list-ref '(a b c d) -1)))310311 (test-group "list-set!"312 (let ((ls (list 'one 'two 'five!)))313 (list-set! ls 2 'three)314 (test '(two three) (cdr ls)))315 ;; Should be an error?316 #;(list-set! '(0 1 2) 1 "oops")317 (test-error (list-set! (list 1 2 3) 3 'foo)))318319 (test-group "mem*"320 (test '(a b c) (memq 'a '(a b c)))321 (test '(b c) (memq 'b '(a b c)))322 (test #f (memq 'a '(b c d)))323 (test #f (memq (list 'a) '(b (a) c)))324 (test '((a) c) (member (list 'a) '(b (a) c)))325 (test '("b" "c") (member "B" '("a" "b" "c") string-ci=?))326 (test '(101 102) (memq 101 '(100 101 102))) ; unspecified in R7RS327 (test '(101 102) (memv 101 '(100 101 102))))328329 (test-group "ass*"330 (define e '((a 1) (b 2) (c 3)))331 (test '(a 1) (assq 'a e))332 (test '(b 2) (assq 'b e))333 (test #f (assq 'd e))334 (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))335 (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))336 (test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =))337 (test '(5 7) (assq 5 '((2 3) (5 7) (11 13)))) ; unspecified in R7RS338 (test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))339 (test-error (assq 5 '(5 6 7)))340 (test-error (assv 5 '(5 6 7)))341 (test-error (assoc 5 '(5 6 7))))342343 (test-group "list-copy"344 (define a '(1 8 2 8)) ; a may be immutable345 (define b (list-copy a))346 (set-car! b 3) ; b is mutable347 (test '((3 8 2 8)) (list b))348 (test '((1 8 2 8)) (list a))))349350(test-group "6.5: Symbols"351 (test-group "symbol=?"352 (test-error (symbol=?))353 (test-error (symbol=? 'a))354 (test-error (symbol=? 'a 1))355 (test-error (symbol=? 'a 'b 1))356 (test #t (symbol=? '|| '||))357 (test #t (symbol=? '|a b| '|a b|))358 (test #t (symbol=? 'a 'a))359 (test #f (symbol=? 'a 'b))360 (test #t (symbol=? 'a 'a 'a))361 (test #f (symbol=? 'a 'a 'b))362 (test #f (symbol=? 'a 'b 'b))363 (test #t (symbol=? 'a 'a 'a 'a))364 (test #f (symbol=? 'a 'a 'a 'b))365 (test #f (symbol=? 'a 'a 'b 'b))366 (test #f (symbol=? 'a 'b 'b 'b))))367368(test-group "6.6: characters"369 (test-group "char*?"370 (test-error "arity" (char=? #\a))371 (test-error "type check" (char=? #\a #\a 1))372 (test-error "no shortcutting" (char=? #\a #\b 1))373 (test #f (char? 1))374 (test #t (char? #\a))375 (test #t (char=? #\a #\a))376 (test #f (char=? #\a #\b))377 (test #t (char=? #\a #\a #\a))378 (test #f (char=? #\a #\b #\a))379 (test #f (char=? #\a #\a #\b))380 (test #t (char=? #\a #\a #\a #\a))381 (test #f (char=? #\a #\b #\a #\a))382 (test #f (char=? #\a #\a #\a #\b))383 (test #t (char<? #\a #\b #\c))384 (test #f (char<? #\a #\b #\b))385 (test #t (char<=? #\a #\b #\b))386 (test #f (char<=? #\a #\b #\a))387 (test #t (char>? #\c #\b #\a))388 (test #f (char>? #\a #\a #\a))389 (test #t (char>=? #\b #\b #\a))390 (test #f (char>=? #\b #\a #\b))))391392(test-group "6.7: strings"393394 (test-group "string*?"395 (test-error "arity" (string=? "a"))396 (test-error "type check" (string=? "a" "a" 1))397 (test-error "no shortcutting" (string=? "a" "b" 1))398 (test #f (string? 1))399 (test #t (string? "a"))400 (test #t (string=? "a" "a"))401 (test #f (string=? "a" "b"))402 (test #t (string=? "a" "a" "a"))403 (test #f (string=? "a" "b" "a"))404 (test #f (string=? "a" "a" "b"))405 (test #t (string=? "a" "a" "a" "a"))406 (test #f (string=? "a" "b" "a" "a"))407 (test #f (string=? "a" "a" "a" "b"))408 (test #t (string<? "a" "b" "c"))409 (test #f (string<? "a" "b" "b"))410 (test #t (string<=? "a" "b" "b"))411 (test #f (string<=? "a" "b" "a"))412 (test #t (string>? "c" "b" "a"))413 (test #f (string>? "c" "b" "b"))414 (test #t (string>=? "b" "b" "a"))415 (test #f (string>=? "b" "a" "b")))416417 (test-group "string->list"418 (test-error (string->list "" 1))419 (test-error (string->list "a" 1 2))420 (test '(#\a) (string->list "a"))421 (test '() (string->list "a" 1))422 (test '(#\b) (string->list "abc" 1 2))423 (test '() (string->list "abc" 2 2)))424425 (test-group "string->vector"426 (test-error (string->vector "" 1))427 (test-error (string->vector "a" 0 2))428 (test #(#\a) (string->vector "a"))429 (test #() (string->vector "a" 1 1))430 (test #(#\b) (string->vector "abc" 1 2))431 (test #() (string->vector "abc" 2 2)))432433 (test-group "vector->string"434 (test-error (vector->string #() 1))435 (test-error (vector->string #(1)))436 (test-error (vector->string #(#\a) 0 2))437 (test "a" (vector->string #(#\a)))438 (test "" (vector->string #(#\a) 1 1))439 (test "b" (vector->string #(#\a #\b #\c) 1 2))440 (test "" (vector->string #(#\a #\b #\c) 2 2))))441442(test-group "6.8: vectors"443444 (test-group "vector-copy"445 (test-error (vector-copy ""))446 (test-error (vector-copy #() #()))447 (test-error (vector-copy #() 1))448 (test-error (vector-copy #(0) -1))449 (test-error (vector-copy #(0) 0 2))450 (test #() (vector-copy #()))451 (test #(0 1 2) (vector-copy #(0 1 2)))452 (test #(1 2) (vector-copy #(0 1 2) 1))453 (test #(1) (vector-copy #(0 1 2) 1 2))454 (test #() (vector-copy #(0 1 2) 1 1)))455456 (test-group "vector-copy!"457 (test-error (vector-copy! ""))458 (test-error (vector-copy! #(0) 0 ""))459 (test-error (vector-copy! #() #() 0))460 (test-error (vector-copy! #() 0 #(0)))461 (test-error (vector-copy! #(0) 1 #(0)))462 (test-error (vector-copy! #(0) 1 #(0) 0))463 (test-error (vector-copy! #(0) 0 #(0) 0 2))464 (test-error (vector-copy! #(0) 0 #(0 1) 1 0))465 (test-assert (vector-copy! #() 0 #()))466 (let ((t #(0 1 2))467 (f #(3 4 5 6)))468 (vector-copy! t 0 f 1 1)469 (test "(vector-copy! t 1 f 1 1)" #(0 1 2) t)470 (vector-copy! t 0 f 0 1)471 (test "(vector-copy! t 0 f 0 1)" #(3 1 2) t)472 (vector-copy! t 0 f 1 3)473 (test "(vector-copy! t 0 f 1 3)" #(4 5 2) t)474 (vector-copy! t 1 f 2)475 (test "(vector-copy! t 1 f 1)" #(4 5 6) t)476 (vector-copy! t 0 f 1)477 (test "(vector-copy! t 0 f)" #(4 5 6) t)))478479 (test-group "vector-append"480 (test-error (vector-append ""))481 (test-error (vector-append #() 1))482 (test #() (vector-append))483 (test #(0) (vector-append #(0)))484 (test #() (vector-append #() #()))485 (test #(0 1) (vector-append #(0) #(1)))486 (test #(0 1 2 3 4 5) (vector-append #(0 1) #(2 3) #(4 5))))487488 (test-group "vector->list"489 (test-error (vector->list ""))490 (test-error (vector->list #() 1))491 (test '() (vector->list #()))492 (test '(0 1 2) (vector->list #(0 1 2)))493 (test '(1 2) (vector->list #(0 1 2) 1))494 (test '(1) (vector->list #(0 1 2) 1 2))495 (test '() (vector->list #(0 1 2) 2 2))))496497(test-group "6.9: bytevectors"498499 (test-group "bytevector-copy"500 (test-error (bytevector-copy ""))501 (test-error (bytevector-copy #u8() #u8()))502 (test-error (bytevector-copy #u8() 1))503 (test-error (bytevector-copy #u8(0) -1))504 (test-error (bytevector-copy #u8(0) 0 2))505 (test #u8() (bytevector-copy #u8()))506 (test #u8(0 1 2) (bytevector-copy #u8(0 1 2)))507 (test #u8(1 2) (bytevector-copy #u8(0 1 2) 1))508 (test #u8(1) (bytevector-copy #u8(0 1 2) 1 2))509 (test #u8() (bytevector-copy #u8(0 1 2) 1 1)))510511 (test-group "bytevector-copy!"512 (test-error (bytevector-copy! ""))513 (test-error (bytevector-copy! #u8(0) 0 ""))514 (test-error (bytevector-copy! #u8() #u8() 0))515 (test-error (bytevector-copy! #u8() 0 #u8(0)))516 (test-error (bytevector-copy! #u8(0) 1 #u8(0)))517 (test-error (bytevector-copy! #u8(0) 1 #u8(0) 0))518 (test-error (bytevector-copy! #u8(0) 0 #u8(0) 0 2))519 (test-error (bytevector-copy! #u8(0) 0 #u8(0 1) 1 0))520 (test-assert (bytevector-copy! #u8() 0 #u8()))521 (let ((t #u8(0 1 2))522 (f #u8(3 4 5 6)))523 (bytevector-copy! t 0 f 1 1)524 (test "(bytevector-copy! t 1 f 1 1)" #u8(0 1 2) t)525 (bytevector-copy! t 0 f 0 1)526 (test "(bytevector-copy! t 0 f 0 1)" #u8(3 1 2) t)527 (bytevector-copy! t 0 f 1 3)528 (test "(bytevector-copy! t 0 f 1 3)" #u8(4 5 2) t)529 (bytevector-copy! t 1 f 2)530 (test "(bytevector-copy! t 1 f 1)" #u8(4 5 6) t)531 (bytevector-copy! t 0 f 1)532 (test "(bytevector-copy! t 0 f)" #u8(4 5 6) t)))533534 (test-group "bytevector-append"535 (test-error (bytevector-append #u8() 1))536 (test #u8() (bytevector-append))537 (test #u8(0) (bytevector-append #u8(0)))538 (test #u8() (bytevector-append #u8() #u8()))539 (test #u8(0 1) (bytevector-append #u8(0) #u8(1)))540 (test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1) #u8(2 3) #u8(4 5)))))541542(test-group "6.10: Control features"543544 (define (1st . a) (car a))545 (define (2nd . a) (cadr a))546 (define (acc proc f . rest) ; accumulate results of `f`547 (let ((a '()))548 (apply proc (lambda args (set! a (cons (apply f args) a))) rest)549 (reverse a)))550551 (define char-add1552 (compose integer->char add1 char->integer))553554 (test-group "string-map"555 (test-error (string-map "abc"))556 (test-error (string-map values))557 (test-error (string-map values '(1 2 3)))558 (test-error (string-map (constantly 1) "abc"))559 (test "" (string-map values ""))560 (test "abc" (string-map values "abc"))561 (test "aaa" (string-map (constantly #\a) "abc"))562 (test "bcd" (string-map char-add1 "abc"))563 (test "abc" (string-map 1st "abc" "123"))564 (test "123" (string-map 2nd "abc" "123"))565 (test "abc" (string-map 1st "abc" "123456"))566 (test "123" (string-map 2nd "abc" "123456")))567568 (test-group "string-for-each"569 (test-error (string-for-each "abc"))570 (test-error (string-for-each values))571 (test-error (string-for-each values '(1 2 3)))572 (test '() (acc string-for-each values ""))573 (test '(#\a #\b #\c) (acc string-for-each values "abc"))574 (test '(#\b #\c #\d) (acc string-for-each char-add1 "abc"))575 (test '((#\a #\1) (#\b #\2) (#\c #\3)) (acc string-for-each list "abc" "123"))576 (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123"))577 (test '(#\a #\b #\c) (acc string-for-each 1st "abc" "123456"))578 (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123456")))579580 (test-group "vector-map"581 (test-error (vector-map #(1 2 3)))582 (test-error (vector-map values))583 (test-error (vector-map values '(1 2 3)))584 (test #() (vector-map values #()))585 (test #(1 2 3) (vector-map values #(1 2 3)))586 (test #(1 1 1) (vector-map (constantly 1) #(1 2 3)))587 (test #(2 3 4) (vector-map add1 #(1 2 3)))588 (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6)))589 (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6)))590 (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6 7 8 9)))591 (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6 7 8 9))))592593 (test-group "vector-for-each"594 (test-error (vector-for-each #(1 2 3)))595 (test-error (vector-for-each values))596 (test-error (vector-for-each values '(1 2 3)))597 (test '() (acc vector-for-each values #()))598 (test '(1 2 3) (acc vector-for-each values #(1 2 3)))599 (test '(2 3 4) (acc vector-for-each add1 #(1 2 3)))600 (test '((1 4) (2 5) (3 6)) (acc vector-for-each list #(1 2 3) #(4 5 6)))601 (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6)))602 (test '(1 2 3) (acc vector-for-each 1st #(1 2 3) #(4 5 6 7 8 9)))603 (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6 7 8 9)))))604605(test-group "6.13: Input"606 (test-assert "read-string returns eof-object for empty string"607 (eof-object? (with-input-from-string "" (lambda () (read-string 1)))))608 (test-assert "read-bytevector returns eof-object for empty string"609 (eof-object? (with-input-from-string "" (lambda () (read-bytevector 1))))))610611(define-syntax catch612 (syntax-rules ()613 ((_ . body) (handle-exceptions e e . body))))614615(test-group "exceptions"616 (test "with-exception-handler (escape)"617 'exception618 (call-with-current-continuation619 (lambda (k)620 (with-exception-handler621 (lambda (e) (k 'exception))622 (lambda () (+ 1 (raise 'an-error)))))))623 (test-error "with-exception-handler (return)"624 (with-exception-handler625 (lambda (e) 'ignore)626 (lambda () (+ 1 (raise 'an-error)))))627 (test-error "with-exception-handler (raise)"628 (with-exception-handler629 (lambda (e) (raise 'another-error))630 (lambda () (+ 1 (raise 'an-error)))))631 (test "with-exception-handler (raise-continuable)"632 '("should be a number" 65)633 (let* ((exception-object #f)634 (return-value635 (with-exception-handler636 (lambda (e) (set! exception-object e) 42)637 (lambda () (+ (raise-continuable "should be a number") 23)))))638 (list exception-object return-value)))639 (test "error-object? (#f)" #f (error-object? 'no))640 (test "error-object? (#t)" #t (error-object? (catch (car '()))))641 (test "error-object-message" "fubar" (error-object-message (catch (error "fubar"))))642 (test "error-object-irritants" '(42) (error-object-irritants (catch (error "fubar" 42))))643 (test "read-error? (#f)" #f (read-error? (catch (car '()))))644 (test "read-error? (#t)" #t (read-error? (catch (read-from-string ")"))))645 (test "file-error? (#f)" #f (file-error? (catch (car '()))))646 (test "file-error? (#t)" #t (file-error? (catch (open-input-file "foo"))))647 (test-error "guard (no match)"648 (guard (condition ((assq 'c condition))) (raise '((a . 42)))))649 (test "guard (match)"650 '(b . 23)651 (guard (condition ((assq 'b condition))) (raise '((b . 23)))))652 (test "guard (=>)"653 42654 (guard (condition ((assq 'a condition) => cdr)) (raise '((a . 42)))))655 (test "guard (multiple)"656 '(b . 23)657 (guard (condition658 ((assq 'a condition) => cdr)659 ((assq 'b condition)))660 (raise '((b . 23))))))661662;; call-with-port is not supposed to close its port when leaving the663;; dynamic extent, only on normal return.664;;665;; XXX TODO: Rewrite in terms of SRFI-6 string port interface, so666;; no call-with-*-string, but use get-output-string and such!667;; Do this when it's clear how to re-export Chicken stuff.668(test-group "string ports"669 (receive (jump-back? jump!)670 (call/cc (lambda (k) (values #f k)))671 (when jump-back? (jump! (void)))672 (let ((string (call-with-output-string673 (lambda (the-string-port)674 (receive (one two three)675 (call-with-port the-string-port676 (lambda (p)677 (display "foo" p)678 ;; Leave the dynamic extent momentarily;679 ;; jump! will immediately return with #t.680 (call/cc (lambda (k) (jump! #t k)))681 (test-assert "Port is still open after excursion"682 (output-port-open? the-string-port))683 (display "bar" p)684 (values 1 2 3)))685 (test "call-with-port returns all values yielded by proc"686 '(1 2 3)687 (list one two three)))688 (test-assert "call-with-port closes the port on normal return"689 (not (output-port-open? the-string-port)))690 (test-assert "It's ok to close output ports that are closed"691 (close-port the-string-port))692 (test-error "input-port-open? fails on output ports"693 (input-port-open? the-string-port))))))694 (test "call-with-port passes the port correctly and allows temporary escapes"695 "foobar" string)))696697 (call-with-input-string "foo"698 (lambda (the-string-port)699 (test-error "output-port-open? fails on input ports"700 (output-port-open? the-string-port))701 (test-assert "Initially, string port is open"702 (input-port-open? the-string-port))703 (test "Reading from string delivers the data"704 'foo (read the-string-port))705 (test "After reading all, we get the eof-object"706 (eof-object) (read the-string-port))707 (test-assert "Port is still open after all reads"708 (input-port-open? the-string-port))709 (close-port the-string-port)710 (test-assert "Port is no longer open after closing it"711 (not (input-port-open? the-string-port)))712 (test-assert "It's ok to close input ports that are already closed"713 (close-port the-string-port)))))714715;; This is for later. We can't define it inside a group because that716;; would make it locally scoped (as a letrec rewrite), which breaks717;; the syntax-rules underscore tests. Very subtle (and annoying), this!718(define (_) 'underscore-procedure)719(define ___ 'triple-underscore-literal)720721(test-group "syntax-rules"722 (test "let-syntax w/ basic syntax-rules"723 100724 (let-syntax ((foo (syntax-rules ()725 ((_ x form)726 (let ((tmp x))727 (if (number? tmp)728 form729 (error "not a number" tmp)))))))730 (foo 2 100)))731 (let-syntax ((foo (syntax-rules ()732 ((_ #(a ...)) (list a ...)))))733 (test "Basic matching of vectors"734 '(1 2 3) (foo #(1 2 3))))735 ;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)736 (let-syntax ((foo (syntax-rules ()737 ((_ (a b) ...)738 (list 'first '(a b) ...))739 ((_ a ...)740 (list 'second '(a) ...)))))741 (test "Basic ellipsis match"742 '(first (1 2) (3 4) (5 6)) (foo (1 2) (3 4) (5 6)))743 (test "Ellipsis match of length 1 does not match length 2"744 '(second (1)) (foo 1))745 (test "Ellipsis match of lists with mismatched lengths (used to fail)"746 '(second ((1 2)) ((3)) ((5 6))) (foo (1 2) (3) (5 6))))747748 (test "letrec-syntax"749 34750 (letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))751 (bar (syntax-rules () ((_ x) (+ x 1)))))752 (foo 33)))753 (test "Basic hygienic rename of syntactic keywords"754 'now755 (let-syntax ((when (syntax-rules ()756 ((when test stmt1 stmt2 ...)757 (if test758 (begin stmt1759 stmt2 ...))))))760 (let ((if #t))761 (when if (set! if 'now))762 if)))763 (test "Basic hygienic rename of shadowed outer let"764 'outer765 (let ((x 'outer))766 (let-syntax ((m (syntax-rules () ((m) x))))767 (let ((x 'inner))768 (m)))))769 (test "Simple recursive letrec expansion"770 7771 (letrec-syntax772 ((my-or (syntax-rules ()773 ((my-or) #f)774 ((my-or e) e)775 ((my-or e1 e2 ...)776 (let ((temp e1))777 (if temp778 temp779 (my-or e2 ...)))))))780 (let ((x #f)781 (y 7)782 (temp 8)783 (let odd?)784 (if even?))785 (my-or x786 (let temp)787 (if y)788 y))))789 ;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"790 (let ((a 1))791 (letrec-syntax792 ((foo (syntax-rules ()793 ((_ b)794 (bar a b))))795 (bar (syntax-rules ()796 ((_ c d)797 (cons c (let ((c 3))798 (list d c 'c)))))))799 (let ((a 2))800 (test "Al* Petrofsky torture test" '(1 2 3 a) (foo a)))))801 (let-syntax802 ((foo (syntax-rules ()803 ((_)804 '#(b)))))805 (test "Quoted symbols inside vectors are stripped of syntactic info"806 '#(b) (foo)))807 (let-syntax ((kw (syntax-rules (baz)808 ((_ baz) "baz")809 ((_ any) "no baz"))))810 (test "syntax-rules keywords match" "baz" (kw baz))811 (test "syntax-rules keywords no match" "no baz" (kw xxx))812 (let ((baz 100))813 (test "keyword loses meaning if shadowed" "no baz" (kw baz))))814 (test "keyword also loses meaning for builtins (from R7RS section 4.3.2)"815 'ok816 (let ((=> #f))817 (cond (#t => 'ok))))818 (test "Nested identifier shadowing works correctly"819 '(3 4)820 (let ((foo 3))821 (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))822 (let ((foo 4))823 (bar foo)))))824 (let-syntax ((c (syntax-rules ()825 ((_)826 (let ((x 10))827 (let-syntax ((z (syntax-rules ()828 ((_) (quote x)))))829 (z))))))830 (c2 (syntax-rules ()831 ((_)832 (let ((x 10))833 (let-syntax834 ((z (syntax-rules ()835 ((_) (let-syntax836 ((w (syntax-rules ()837 ((_) (quote x)))))838 (w))))))839 (z)))))))840 ;; Reported by Matthew Flatt841 (test "strip-syntax cuts across three levels of syntax"842 "x" (symbol->string (c)))843 (test "strip-syntax cuts across four levels of syntax"844 "x" (symbol->string (c2))))845 (let-syntax ((foo (syntax-rules846 ___ ()847 ((_ vals ___) (list '... vals ___)))))848 (test "Alternative ellipsis (from SRFI-46)"849 '(... 1 2 3) (foo 1 2 3)))850 (let-syntax ((let-alias (syntax-rules851 ___ ()852 ((_ new old code ___)853 (let-syntax854 ((new855 (syntax-rules ()856 ((_ args ...) (old args ...)))))857 code ___)))))858 (let-alias inc (lambda (x) (+ 1 x))859 (test "Ellipsis rules are reset in new macro expansion phase"860 3 (inc 2))))861 (let-syntax ((foo (syntax-rules ()862 ((_ (a ... b) ... (c d))863 (list (list (list a ...) ... b ...) c d))864 ((_ #(a ... b) ... #(c d) #(e f))865 (list (list (vector a ...) ... b ...) c d e f))866 ((_ #(a ... b) ... #(c d))867 (list (list (vector a ...) ... b ...) c d)))))868 (test-group "rest patterns after ellipsis (SRFI-46 smoke test)"869 (test '(() 1 2) (foo (1 2)))870 (test '(((1) 2) 3 4) (foo (1 2) (3 4)))871 (test '(((1 2) (4) 3 5) 6 7)872 (foo (1 2 3) (4 5) (6 7)))873 (test '(() 1 2)874 (foo #(1 2)))875 (test '((#() 1) 2 3)876 (foo #(1) #(2 3)))877 (test '((#(1 2) 3) 4 5)878 (foo #(1 2 3) #(4 5)))879 (test '((#(1 2) 3) 4 5 6 7)880 (foo #(1 2 3) #(4 5) #(6 7)))881 (test '(() 1 2 3 4)882 (foo #(1 2) #(3 4)))883 (test '((#(1) 2) 3 4 5 6)884 (foo #(1 2) #(3 4) #(5 6)))885 (test '((#(1 2) #(4) 3 5) 6 7 8 9)886 (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))))887 (let-syntax ((foo (syntax-rules ()888 ((_ #((a) ...)) (list a ...)))))889 (test "Bug discovered during implementation of rest patterns"890 '(1)891 (foo #((1)))))892 ;; R7RS: (<ellipsis> <template>) is like <template>, ignoring893 ;; occurrances of <ellipsis> inside the template.894 (let-syntax ((be-like-begin895 (syntax-rules ()896 ((be-like-begin name)897 (define-syntax name898 (syntax-rules ()899 ((name expr (... ...))900 (begin expr (... ...)))))))))901 (be-like-begin sequence)902 (test "be-like-begin from R7RS 4.3.2 (nested ellipsis are not expanded)"903 4 (sequence 1 2 3 4)))904 (let-syntax ((ignore-underscores905 (syntax-rules ()906 ((_ _ _ _) (_)))))907 (test "underscores are ignored in patterns"908 'underscore-procedure (ignore-underscores _ b c)))909910 (test-group "undefined behaviours: mixing keywords, ellipsis and underscores"911 (test-group "underscore as keyword literal"912 (define-syntax match-literal-underscores ; for eval913 (syntax-rules (_)914 ((x a _ c) (_))915 ((x _ b c) 1)))916 (test-error "Missing literal underscore keyword causes syntax-error"917 (eval '(match-literal-underscores d e f)))918 (test "Literal underscore matches"919 1 (match-literal-underscores _ h i))920 (test "Literal underscore matches even if it refers to toplevel binding"921 'underscore-procedure (match-literal-underscores g _ i)))922923 (test-group "underscore as ellipsis"924 ;; It's undefined what this should do. Logically, it should be925 ;; possible to bind _ as an ellipsis identifier.926 (define-syntax match-ellipsis-underscores ; for eval927 (syntax-rules _ () ((x a _ c) (list a _ c))))928 (test-error "No rule matching if prefix is omitted"929 (eval '(match-ellipsis-underscores)))930 (test "Only prefix is supplied"931 '(1) (match-ellipsis-underscores 1))932 (test "Ellipsis does its work if multiple arguments given"933 '(1 2 3 4 5 6) (match-ellipsis-underscores 1 2 3 4 5 6)))934935 (test-group "underscore as ellipsis mixed with underscore literal"936 ;; Even more undefined behaviour: mixing literals and ellipsis identifiers937 ;; Currently, ellipsis identifiers have precedence over the other two.938 (define-syntax match-ellipsis-and-literals-underscores ; for eval939 (syntax-rules _ (_) ((x a _ c) (list a _ c))))940 (test-error "No rule matching if prefix is omitted"941 (eval '(match-ellipsis-and-literals-underscores)))942 (test '(1) (match-ellipsis-and-literals-underscores 1))943 (test '(1 2 3) (match-ellipsis-and-literals-underscores 1 2 3))944 (test '(1 2 3 4 5 6) (match-ellipsis-and-literals-underscores 1 2 3 4 5 6)))945946 (test-group "\"custom\" ellipsis and literal of the same identifier"947 ;; This is similar to the above, but maybe a little simpler because948 ;; it does not use reserved names:949 (define-syntax match-ellipsis-literals950 (syntax-rules ___ (___)951 ((_ x ___) (list x ___))))952 (test "Ellipsis as literals"953 '(1) (match-ellipsis-literals 1))954 (test "Ellipsis as literals multiple args"955 '(1 2) (match-ellipsis-literals 1 2))956 (test "Toplevel binding of the same name as ellipsis"957 '(1 triple-underscore-literal) (match-ellipsis-literals 1 ___))))958959 (letrec-syntax ((usetmp960 (syntax-rules ()961 ((_ var)962 (list var))))963 (withtmp964 (syntax-rules ()965 ((_ val exp)966 (let ((tmp val))967 (exp tmp))))))968 (test "Passing a macro as argument to macro"969 '(99)970 (withtmp 99 usetmp)))971972 ;; renaming of keyword argument (#277)973 (let-syntax ((let-hello-proc974 (syntax-rules ()975 ((_ procname code ...)976 (let ((procname (lambda (#!key (who "world"))977 (string-append "hello, " who))))978 code ...)))))979 (let-hello-proc bar980 ;; This is not R7RS, but R7RS should not interfere with other981 ;; CHICKEN features!982 (test "DSSSL keyword arguments aren't renamed (not R7RS)"983 "hello, XXX" (bar who: "XXX")))))984985(test-group "define-record-type"986 (define-record-type foo (make-foo) foo?)987 (define foo (make-foo))988 (test-assert "Record instances satisfy their predicates" (foo? foo))989 (define-record-type foo (make-foo) foo?)990 (test-assert "Record type definitions are generative" (not (foo? foo))))991992(test-group "open-input-bytevector"993 (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)994 (let ((bv (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)))995 (read-bytevector 12 (open-input-bytevector bv)))))996997(test-group "open-output-bytevector"998 (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)999 (let ((p (open-output-bytevector)))1000 (write-bytevector (bytevector 0 1 2 10 13) p)1001 (write-bytevector (bytevector 40 41 42 128) p)1002 (write-bytevector (bytevector 140 240 255) p)1003 (close-output-port p)1004 (get-output-bytevector p))))10051006(test-end "r7rs tests")10071008(test-exit)