~ chicken-core (master) /tests/r7rs-tests-2.scm
Trap1(import (scheme base)2 (chicken base)3 (chicken io)4 (chicken port)5 (chicken string)6 (scheme char)7 (scheme eval)8 (scheme file)9 (scheme read)10 (scheme write))1112(define (read-from-string s)13 (with-input-from-string s read))1415(include "test.scm")1617(define-syntax test18 (syntax-rules ()19 ((_ val expr) (test-equal expr val))20 ((_ name val expr) (test-equal name expr val))))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(test-group "4.2.1: Conditionals"56 (test-group "cond-expand"57 (test "(scheme base)"58 'scheme-base59 (cond-expand60 ((library (scheme base)) 'scheme-base)61 (else #f)))62 (test "(chicken base)"63 'chicken-base64 (cond-expand65 ((library (chicken base)) 'chicken-base)66 (else #f)))67 (test "chicken.base"68 'chicken.base69 (cond-expand70 ((library chicken.base) 'chicken.base)71 (else #f)))72 (test "(bogus identifier)"73 #f74 (cond-expand75 ((library (bogus identifier)) 'bogus-identifier)76 (else #f)))))7778(test-group "6.2.6: numerical operations"79 (test-group "floor/...truncate-remainder"80 (test '(2 1) (receive (floor/ 5 2)))81 (test 2 (floor-quotient 5 2))82 (test 1 (floor-remainder 5 2))83 (test '(-3 1) (receive (floor/ -5 2)))84 (test -3 (floor-quotient -5 2))85 (test 1 (floor-remainder -5 2))86 (test '(-3 -1) (receive (floor/ 5 -2)))87 (test -3 (floor-quotient 5 -2))88 (test -1 (floor-remainder 5 -2))89 (test '(2 -1) (receive (floor/ -5 -2)))90 (test 2 (floor-quotient -5 -2))91 (test -1 (floor-remainder -5 -2))92 (test '(2.0 -1.0) (receive (floor/ -5 -2.0)))93 ;; From the Guile manual94 (test 12 (floor-quotient 123 10))95 (test 3 (floor-remainder 123 10))96 (test '(12 3) (receive (floor/ 123 10)))97 (test '(-13 -7) (receive (floor/ 123 -10)))98 (test '(-13 7) (receive (floor/ -123 10)))99 (test '(12 -3) (receive (floor/ -123 -10)))100101 (test '(2 1) (receive (truncate/ 5 2)))102 (test 2 (truncate-quotient 5 2))103 (test 1 (truncate-remainder 5 2))104 (test '(-2 -1) (receive (truncate/ -5 2)))105 (test -2 (truncate-quotient -5 2))106 (test -1 (truncate-remainder -5 2))107 (test '(-2 1) (receive (truncate/ 5 -2)))108 (test -2 (truncate-quotient 5 -2))109 (test 1 (truncate-remainder 5 -2))110 (test '(2 -1) (receive (truncate/ -5 -2)))111 (test 2 (truncate-quotient -5 -2))112 (test -1 (truncate-remainder -5 -2))113 (test '(2.0 -1.0) (receive (truncate/ -5.0 -2)))114 (test 2.0 (truncate-quotient -5.0 -2))115 (test -1.0 (truncate-remainder -5.0 -2))116 ;; From the Guile manual117 (test 12 (truncate-quotient 123 10))118 (test 3 (truncate-remainder 123 10))119 (test '(12 3) (receive (truncate/ 123 10)))120 (test '(-12 3) (receive (truncate/ 123 -10)))121 (test '(-12 -3) (receive (truncate/ -123 10)))122 (test '(12 -3) (receive (truncate/ -123 -10))))123124 (test-group "quotient, remainder and modulo"125 (test 1 (modulo 13 4))126 (test 1 (remainder 13 4))127 (test 3 (modulo -13 4))128 (test -1 (remainder -13 4))129 (test -3 (modulo 13 -4))130 (test 1 (remainder 13 -4))131 (test -1 (modulo -13 -4))132 (test -1 (remainder -13 -4))133 (test -1.0 (remainder -13 -4.0)))134135 (test-group "square"136 (test 1 (square 1))137 (test 16 (square 4))138 (test 16.0 (square 4.0))))139140(test-group "6.3: booleans"141 ;; How silly...142 (test-group "not"143 (test #f (not #t))144 (test #f (not 3))145 (test #f (not (list 3)))146 (test #t (not #f))147 (test #f (not '()))148 (test #f (not (list)))149 (test #f (not 'nil))150 (test-error (not))151 (test-error (not 1 2)))152153 (test-group "long boolean literals"154 (test #t (read-from-string "#t"))155 (test #f (read-from-string "#f"))156 (test #t (read-from-string "#true"))157 (test #f (read-from-string "#false"))158 (test-error (read-from-string "#faux")))159160 (test-group "boolean=?"161 (test #t (boolean=? #t #t))162 (test #t (boolean=? #t #t #t #t))163 (test #t (boolean=? #f #f))164 (test #t (boolean=? #f #f #f #f))165 (test #f (boolean=? #f #t))166 (test #f (boolean=? #f #t #t #t))167 (test #f (boolean=? #f #f #t #t))168 (test #f (boolean=? #f #f #f #t))169 (test #f (boolean=? #t #f #f #f))170 (test #f (boolean=? #t #f #f #t))171 (test #f (boolean=? #t #t #f #t))172 (test #f (boolean=? #f #f #f #t))173 (test #f (boolean=? #f #t #f #f))174 (test-error (boolean=? #f))175 (test-error (boolean=? #f 1))176 (test-error "no shortcutting" (boolean=? #f #t 2))))177178(test-group "6.4: pairs and lists"179 (test-group "pair?"180 (test #t (pair? '(a . b)))181 (test #t (pair? '(a b c)))182 (test #f (pair? '()))183 (test #f (pair? '#(a b)))184 (test #f (pair? #f))185 (test #f (pair? #t))186 (test #f (pair? "some string"))187 (test #f (pair? 123)))188189 (test-group "cons"190 (test '(a) (cons 'a '()))191 (test '((a) b c d) (cons '(a) '(b c d)))192 (test '("a" b c) (cons "a" '(b c)))193 (test '(a . 3) (cons 'a 3))194 (test '((a b) . c) (cons '(a b) 'c)))195196 (test-group "car"197 (test 'a (car '(a b c)))198 (test '(a) (car '((a) b c d)))199 (test 1 (car '(1 . 2)))200 (test-error (car '()))201 (test-error (car '#(1 2 3)))202 (test-error (car "not a pair")))203204 (test-group "cdr"205 (test '(b c d) (cdr '((a) b c d)))206 (test 2 (cdr '(1 . 2)))207 (test-error (cdr '()))208 (test-error (cdr '#(1 2 3)))209 (test-error (cdr "not a pair")))210211 (test-group "set-car!"212 (define (f) (list 'not-a-constant-list))213 (define (g) '(constant-list))214 ;; Examples from the text are very incomplete and strange215 (let ((res (f)))216 (set-car! res 2)217 (test 2 (car res))218 (set-car! (f) 3)219 (test 'not-a-constant-list (car (f))))220 ;; XXX Should this *raise* an error? R5RS also says this it "is an error"221 #;(test-error (set-car! (g) 3))222 (test-error (set-car! 'x 'y)))223224 (test-group "set-cdr!"225 (define (f) (list 'not-a-constant-list))226 (define (g) '(constant-list))227 ;; Examples from the text are very incomplete and strange228 (let ((res (f)))229 (set-cdr! res 2)230 (test 2 (cdr res))231 (set-cdr! (f) 3)232 (test '() (cdr (f))))233 ;; XXX Should this *raise* an error? R5RS also says this it "is an error"234 #;(test-error (set-cdr! (g) 3))235 (test-error (set-cdr! 'x 'y)))236237 (test-group "c..r (base)"238 (test 'x (caar '((x) y)))239 (test-error (caar '(x y)))240 (test 'y (cadr '((x) y)))241 (test-error (cadr '(x)))242 (test '() (cdar '((x) y)))243 (test-error (cdar '(x)))244 (test '() (cddr '((x) y)))245 (test-error (cddr '(x))))246247 ;; TODO: c..r (cxr)248249 (test-group "null?"250 (test #t (null? '()))251 (test #t (null? (list)))252 (test #f (null? '(a)))253 (test #f (null? 'a))254 (test #f (null? '#()))255 (test #f (null? "foo")))256257 (test-group "list?"258 (test #t (list? '(a b c)))259 (test #t (list? (list 'a 'b 'c)))260 (test #t (list? '()))261 (test #f (list? '(a . b)))262 (let ((x (list 'a)))263 (set-cdr! x x)264 (test #f (list? x)))265 (test #f (list? 'a))266 (test #f (list? '#()))267 (test #f (list? "foo")))268269 (test-group "make-list"270 (test-error (make-list))271 (test '() (make-list 0))272 (test '(#f) (make-list 1)) ; Unspecified273274 (test '(#f) (make-list 1 #f))275 ;(test-error (make-list 1 2 3))276 (test '(3 3) (make-list 2 3))277 (test '() (make-list 0 3))278 (test-error (make-list -1 3))279 (test-error (make-list #f 3)))280281 (test-group "list"282 (test '(a 7 c) (list 'a (+ 3 4) 'c))283 (test '() (list))284 (test '(#f) (list #f))285 (test '(a b c) (list 'a 'b 'c)))286287 (test-group "length"288 (test 3 (length '(a b c)))289 (test 3 (length '(a (b) (c d e))))290 (test 0 (length '()))291292 (test-error (length '(x . y)))293 (test-error (length '#(x y)))294 (test-error (length "foo")))295296 (test-group "append"297 (test '(x y) (append '(x) '(y)))298 (test '(a b c d) (append '(a) '(b c d)))299 (test '(a (b) (c)) (append '(a (b)) '((c))))300 (test '(a b c . d) (append '(a b) '(c . d)))301 (test 'a (append '() 'a))302 (test '(a b . c) (append '(a b) 'c))303 (test-error (append 'x '()))304 (test-error (append '(x) 'y '())))305306 (test-group "reverse"307 (test '(c b a) (reverse '(a b c)))308 (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))309 (test '() (reverse '()))310 (test-error (reverse '(a . b)))311 (test-error (reverse '(a b) '(c d)))312 (test-error (reverse 'a))313 (test-error (reverse '#(a b c)))314 (test-error (reverse "foo")))315316 (test-group "list-tail"317 (test '(a b c d e f) (list-tail '(a b c d e f) 0))318 (test '(d e f) (list-tail '(a b c d e f) 3))319 (test '() (list-tail '(a b c d e f) 6))320 (test '() (list-tail '() 0))321 (test-error (list-tail '(a b c d e f) -1))322 (test-error (list-tail '(a b c d e f) 7))323 (test-error (list-tail '(a b c d e . f) 6)))324325 (test-group "list-ref"326 (test 'a (list-ref '(a b c d) 0))327 (test 'b (list-ref '(a b c d) 1))328 (test 'c (list-ref '(a b c d) 2))329 (test 'd (list-ref '(a b c d) 3))330 (test-error (list-ref '(a b c d) 4))331 (test-error (list-ref '(a b c d) -1)))332333 (test-group "list-set!"334 (let ((ls (list 'one 'two 'five!)))335 (list-set! ls 2 'three)336 (test '(two three) (cdr ls)))337 ;; Should be an error?338 #;(list-set! '(0 1 2) 1 "oops")339 (test-error (list-set! (list 1 2 3) 3 'foo)))340341 (test-group "mem*"342 (test '(a b c) (memq 'a '(a b c)))343 (test '(b c) (memq 'b '(a b c)))344 (test #f (memq 'a '(b c d)))345 (test #f (memq (list 'a) '(b (a) c)))346 (test '((a) c) (member (list 'a) '(b (a) c)))347 (test '("b" "c") (member "B" '("a" "b" "c") string-ci=?))348 (test '(101 102) (memq 101 '(100 101 102))) ; unspecified in R7RS349 (test '(101 102) (memv 101 '(100 101 102))))350351 (test-group "ass*"352 (define e '((a 1) (b 2) (c 3)))353 (test '(a 1) (assq 'a e))354 (test '(b 2) (assq 'b e))355 (test #f (assq 'd e))356 (test #f (assq (list 'a) '(((a)) ((b)) ((c)))))357 (test '((a)) (assoc (list 'a) '(((a)) ((b)) ((c)))))358 (test '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =))359 (test '(5 7) (assq 5 '((2 3) (5 7) (11 13)))) ; unspecified in R7RS360 (test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))361 (test-error (assq 5 '(5 6 7)))362 (test-error (assv 5 '(5 6 7)))363 (test-error (assoc 5 '(5 6 7))))364365 (test-group "list-copy"366 (define a '(1 8 2 8)) ; a may be immutable367 (define b (list-copy a))368 (set-car! b 3) ; b is mutable369 (test '((3 8 2 8)) (list b))370 (test '((1 8 2 8)) (list a))))371372(test-group "6.5: Symbols"373 (test-group "symbol=?"374 (test-error (symbol=?))375 (test-error (symbol=? 'a))376 (test-error (symbol=? 'a 1))377 (test-error (symbol=? 'a 'b 1))378 (test #t (symbol=? '|| '||))379 (test #t (symbol=? '|a b| '|a b|))380 (test #t (symbol=? 'a 'a))381 (test #f (symbol=? 'a 'b))382 (test #t (symbol=? 'a 'a 'a))383 (test #f (symbol=? 'a 'a 'b))384 (test #f (symbol=? 'a 'b 'b))385 (test #t (symbol=? 'a 'a 'a 'a))386 (test #f (symbol=? 'a 'a 'a 'b))387 (test #f (symbol=? 'a 'a 'b 'b))388 (test #f (symbol=? 'a 'b 'b 'b))))389390(test-group "6.6: characters"391 (test-group "char*?"392 (test-error "arity" (char=? #\a))393 (test-error "type check" (char=? #\a #\a 1))394 (test-error "no shortcutting" (char=? #\a #\b 1))395 (test #f (char? 1))396 (test #t (char? #\a))397 (test #t (char=? #\a #\a))398 (test #f (char=? #\a #\b))399 (test #t (char=? #\a #\a #\a))400 (test #f (char=? #\a #\b #\a))401 (test #f (char=? #\a #\a #\b))402 (test #t (char=? #\a #\a #\a #\a))403 (test #f (char=? #\a #\b #\a #\a))404 (test #f (char=? #\a #\a #\a #\b))405 (test #t (char<? #\a #\b #\c))406 (test #f (char<? #\a #\b #\b))407 (test #t (char<=? #\a #\b #\b))408 (test #f (char<=? #\a #\b #\a))409 (test #t (char>? #\c #\b #\a))410 (test #f (char>? #\a #\a #\a))411 (test #t (char>=? #\b #\b #\a))412 (test #f (char>=? #\b #\a #\b))))413414(test-group "6.7: strings"415416 (test-group "string*?"417 (test-error "arity" (string=? "a"))418 (test-error "type check" (string=? "a" "a" 1))419 (test-error "no shortcutting" (string=? "a" "b" 1))420 (test #f (string? 1))421 (test #t (string? "a"))422 (test #t (string=? "a" "a"))423 (test #f (string=? "a" "b"))424 (test #t (string=? "a" "a" "a"))425 (test #f (string=? "a" "b" "a"))426 (test #f (string=? "a" "a" "b"))427 (test #t (string=? "a" "a" "a" "a"))428 (test #f (string=? "a" "b" "a" "a"))429 (test #f (string=? "a" "a" "a" "b"))430 (test #t (string<? "a" "b" "c"))431 (test #f (string<? "a" "b" "b"))432 (test #t (string<=? "a" "b" "b"))433 (test #f (string<=? "a" "b" "a"))434 (test #t (string>? "c" "b" "a"))435 (test #f (string>? "c" "b" "b"))436 (test #t (string>=? "b" "b" "a"))437 (test #f (string>=? "b" "a" "b")))438439 (test-group "string->list"440 (test-error (string->list "" 1))441 (test-error (string->list "a" 1 2))442 (test '(#\a) (string->list "a"))443 (test '() (string->list "a" 1))444 (test '(#\b) (string->list "abc" 1 2))445 (test '() (string->list "abc" 2 2)))446447 (test-group "string->vector"448 (test-error (string->vector "" 1))449 (test-error (string->vector "a" 0 2))450 (test #(#\a) (string->vector "a"))451 (test #() (string->vector "a" 1 1))452 (test #(#\b) (string->vector "abc" 1 2))453 (test #() (string->vector "abc" 2 2)))454455 (test-group "string-copy!"456 (let ((r "abcdef"))457 (string-copy! r 2 r 0 3)458 (test "string-copy! r 2 r 0 3)" "ababcf" r)))459460 (test-group "vector->string"461 (test-error (vector->string #() 1))462 (test-error (vector->string #(1)))463 (test-error (vector->string #(#\a) 0 2))464 (test "a" (vector->string #(#\a)))465 (test "" (vector->string #(#\a) 1 1))466 (test "b" (vector->string #(#\a #\b #\c) 1 2))467 (test "" (vector->string #(#\a #\b #\c) 2 2))))468469(test-group "6.8: vectors"470471 (test-group "vector-copy"472 (test-error (vector-copy ""))473 (test-error (vector-copy #() #()))474 (test-error (vector-copy #() 1))475 (test-error (vector-copy #(0) -1))476 (test-error (vector-copy #(0) 0 2))477 (test #() (vector-copy #()))478 (test #(0 1 2) (vector-copy #(0 1 2)))479 (test #(1 2) (vector-copy #(0 1 2) 1))480 (test #(1) (vector-copy #(0 1 2) 1 2))481 (test #() (vector-copy #(0 1 2) 1 1)))482483 (test-group "vector-copy!"484 (test-error (vector-copy! ""))485 (test-error (vector-copy! #(0) 0 ""))486 (test-error (vector-copy! #() #() 0))487 (test-error (vector-copy! #() 0 #(0)))488 (test-error (vector-copy! #(0) 1 #(0)))489 (test-error (vector-copy! #(0) 1 #(0) 0))490 (test-error (vector-copy! #(0) 0 #(0) 0 2))491 (test-error (vector-copy! #(0) 0 #(0 1) 1 0))492 (test-assert (vector-copy! #() 0 #()))493 (let ((t #(0 1 2))494 (f #(3 4 5 6))495 (r #(1 2 3 4 5)))496 (vector-copy! t 0 f 1 1)497 (test "(vector-copy! t 1 f 1 1)" #(0 1 2) t)498 (vector-copy! t 0 f 0 1)499 (test "(vector-copy! t 0 f 0 1)" #(3 1 2) t)500 (vector-copy! t 0 f 1 3)501 (test "(vector-copy! t 0 f 1 3)" #(4 5 2) t)502 (vector-copy! t 1 f 2)503 (test "(vector-copy! t 1 f 1)" #(4 5 6) t)504 (vector-copy! t 0 f 1)505 (test "(vector-copy! t 0 f)" #(4 5 6) t)506 (vector-copy! r 2 r 0 3)507 (test "(vector-copy! r 2 r 0 3)" #(1 2 1 2 3) r)))508509 (test-group "vector-append"510 (test-error (vector-append ""))511 (test-error (vector-append #() 1))512 (test #() (vector-append))513 (test #(0) (vector-append #(0)))514 (test #() (vector-append #() #()))515 (test #(0 1) (vector-append #(0) #(1)))516 (test #(0 1 2 3 4 5) (vector-append #(0 1) #(2 3) #(4 5))))517518 (test-group "vector->list"519 (test-error (vector->list ""))520 (test-error (vector->list #() 1))521 (test '() (vector->list #()))522 (test '(0 1 2) (vector->list #(0 1 2)))523 (test '(1 2) (vector->list #(0 1 2) 1))524 (test '(1) (vector->list #(0 1 2) 1 2))525 (test '() (vector->list #(0 1 2) 2 2))))526527(test-group "6.9: bytevectors"528529 (test-group "bytevector-copy"530 (test-error (bytevector-copy ""))531 (test-error (bytevector-copy #u8() #u8()))532 (test-error (bytevector-copy #u8() 1))533 (test-error (bytevector-copy #u8(0) -1))534 (test-error (bytevector-copy #u8(0) 0 2))535 (test #u8() (bytevector-copy #u8()))536 (test #u8(0 1 2) (bytevector-copy #u8(0 1 2)))537 (test #u8(1 2) (bytevector-copy #u8(0 1 2) 1))538 (test #u8(1) (bytevector-copy #u8(0 1 2) 1 2))539 (test #u8() (bytevector-copy #u8(0 1 2) 1 1)))540541 (test-group "bytevector-copy!"542 (test-error (bytevector-copy! ""))543 (test-error (bytevector-copy! #u8(0) 0 ""))544 (test-error (bytevector-copy! #u8() #u8() 0))545 (test-error (bytevector-copy! #u8() 0 #u8(0)))546 (test-error (bytevector-copy! #u8(0) 1 #u8(0)))547 (test-error (bytevector-copy! #u8(0) 1 #u8(0) 0))548 (test-error (bytevector-copy! #u8(0) 0 #u8(0) 0 2))549 (test-error (bytevector-copy! #u8(0) 0 #u8(0 1) 1 0))550 (test-assert (bytevector-copy! #u8() 0 #u8()))551 (let ((t #u8(0 1 2))552 (f #u8(3 4 5 6))553 (r #u8(1 2 3 4 5)))554 (bytevector-copy! t 0 f 1 1)555 (test "(bytevector-copy! t 1 f 1 1)" #u8(0 1 2) t)556 (bytevector-copy! t 0 f 0 1)557 (test "(bytevector-copy! t 0 f 0 1)" #u8(3 1 2) t)558 (bytevector-copy! t 0 f 1 3)559 (test "(bytevector-copy! t 0 f 1 3)" #u8(4 5 2) t)560 (bytevector-copy! t 1 f 2)561 (test "(bytevector-copy! t 1 f 1)" #u8(4 5 6) t)562 (bytevector-copy! t 0 f 1)563 (test "(bytevector-copy! t 0 f)" #u8(4 5 6) t)564 (bytevector-copy! r 2 r 0 3)565 (test "(bytevector-copy! r 2 r 0 3)" #u8(1 2 1 2 3) r)))566567 (test-group "bytevector-append"568 (test-error (bytevector-append #u8() 1))569 (test #u8() (bytevector-append))570 (test #u8(0) (bytevector-append #u8(0)))571 (test #u8() (bytevector-append #u8() #u8()))572 (test #u8(0 1) (bytevector-append #u8(0) #u8(1)))573 (test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1) #u8(2 3) #u8(4 5))))574575 (test-group "bytevector read syntax"576 (test (bytevector 1 2 3) (read-from-string "#u8(1 2 3)")))577578 )579580(test-group "6.10: Control features"581582 (define (1st . a) (car a))583 (define (2nd . a) (cadr a))584 (define (acc proc f . rest) ; accumulate results of `f`585 (let ((a '()))586 (apply proc (lambda args (set! a (cons (apply f args) a))) rest)587 (reverse a)))588589 (define char-add1590 (compose integer->char add1 char->integer))591592 (test-group "string-map"593 (test-error (string-map "abc"))594 (test-error (string-map values))595 (test-error (string-map values '(1 2 3)))596 (test-error (string-map (constantly 1) "abc"))597 (test "" (string-map values ""))598 (test "abc" (string-map values "abc"))599 (test "aaa" (string-map (constantly #\a) "abc"))600 (test "bcd" (string-map char-add1 "abc"))601 (test "abc" (string-map 1st "abc" "123"))602 (test "123" (string-map 2nd "abc" "123"))603 (test "abc" (string-map 1st "abc" "123456"))604 (test "123" (string-map 2nd "abc" "123456")))605606 (test-group "string-for-each"607 (test-error (string-for-each "abc"))608 (test-error (string-for-each values))609 (test-error (string-for-each values '(1 2 3)))610 (test '() (acc string-for-each values ""))611 (test '(#\a #\b #\c) (acc string-for-each values "abc"))612 (test '(#\b #\c #\d) (acc string-for-each char-add1 "abc"))613 (test '((#\a #\1) (#\b #\2) (#\c #\3)) (acc string-for-each list "abc" "123"))614 (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123"))615 (test '(#\a #\b #\c) (acc string-for-each 1st "abc" "123456"))616 (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123456")))617618 (test-group "vector-map"619 (test-error (vector-map #(1 2 3)))620 (test-error (vector-map values))621 (test-error (vector-map values '(1 2 3)))622 (test #() (vector-map values #()))623 (test #(1 2 3) (vector-map values #(1 2 3)))624 (test #(1 1 1) (vector-map (constantly 1) #(1 2 3)))625 (test #(2 3 4) (vector-map add1 #(1 2 3)))626 (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6)))627 (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6)))628 (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6 7 8 9)))629 (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6 7 8 9))))630631 (test-group "vector-for-each"632 (test-error (vector-for-each #(1 2 3)))633 (test-error (vector-for-each values))634 (test-error (vector-for-each values '(1 2 3)))635 (test '() (acc vector-for-each values #()))636 (test '(1 2 3) (acc vector-for-each values #(1 2 3)))637 (test '(2 3 4) (acc vector-for-each add1 #(1 2 3)))638 (test '((1 4) (2 5) (3 6)) (acc vector-for-each list #(1 2 3) #(4 5 6)))639 (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6)))640 (test '(1 2 3) (acc vector-for-each 1st #(1 2 3) #(4 5 6 7 8 9)))641 (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6 7 8 9)))))642643(test-group "6.13: Input"644 (test-assert "read-string returns eof-object for empty string"645 (eof-object? (with-input-from-string "" (lambda () (read-string 1)))))646 (test-assert "read-bytevector returns eof-object for empty string"647 (eof-object? (with-input-from-string "" (lambda () (read-bytevector 1))))))648649(define-syntax catch650 (syntax-rules ()651 ((_ . body) (handle-exceptions e e . body))))652653(test-group "exceptions"654 (test "with-exception-handler (escape)"655 'exception656 (call-with-current-continuation657 (lambda (k)658 (with-exception-handler659 (lambda (e) (k 'exception))660 (lambda () (+ 1 (raise 'an-error)))))))661 (test-error "with-exception-handler (return)"662 (with-exception-handler663 (lambda (e) 'ignore)664 (lambda () (+ 1 (raise 'an-error)))))665 (test-error "with-exception-handler (raise)"666 (with-exception-handler667 (lambda (e) (raise 'another-error))668 (lambda () (+ 1 (raise 'an-error)))))669 (test "with-exception-handler (raise-continuable)"670 '("should be a number" 65)671 (let* ((exception-object #f)672 (return-value673 (with-exception-handler674 (lambda (e) (set! exception-object e) 42)675 (lambda () (+ (raise-continuable "should be a number") 23)))))676 (list exception-object return-value)))677 (test "error-object? (#f)" #f (error-object? 'no))678 (test "error-object? (#t)" #t (error-object? (catch (car '()))))679 (test "error-object-message" "fubar" (error-object-message (catch (error "fubar"))))680 (test "error-object-irritants" '(42) (error-object-irritants (catch (error "fubar" 42))))681 (test "read-error? (#f)" #f (read-error? (catch (car '()))))682 (test "read-error? (#t)" #t (read-error? (catch (read-from-string ")"))))683 (test "file-error? (#f)" #f (file-error? (catch (car '()))))684 (test "file-error? (#t)" #t (file-error? (catch (open-input-file "foo"))))685 (test-error "guard (no match)"686 (guard (condition ((assq 'c condition))) (raise '((a . 42)))))687 (test "guard (match)"688 '(b . 23)689 (guard (condition ((assq 'b condition))) (raise '((b . 23)))))690 (test "guard (=>)"691 42692 (guard (condition ((assq 'a condition) => cdr)) (raise '((a . 42)))))693 (test "guard (multiple)"694 '(b . 23)695 (guard (condition696 ((assq 'a condition) => cdr)697 ((assq 'b condition)))698 (raise '((b . 23))))))699700;; call-with-port is not supposed to close its port when leaving the701;; dynamic extent, only on normal return.702;;703;; XXX TODO: Rewrite in terms of SRFI-6 string port interface, so704;; no call-with-*-string, but use get-output-string and such!705;; Do this when it's clear how to re-export Chicken stuff.706(test-group "string ports"707 (receive (jump-back? jump!)708 (call/cc (lambda (k) (values #f k)))709 (when jump-back? (jump! (void)))710 (let ((string (call-with-output-string711 (lambda (the-string-port)712 (receive (one two three)713 (call-with-port the-string-port714 (lambda (p)715 (display "foo" p)716 ;; Leave the dynamic extent momentarily;717 ;; jump! will immediately return with #t.718 (call/cc (lambda (k) (jump! #t k)))719 (test-assert "Port is still open after excursion"720 (output-port-open? the-string-port))721 (display "bar" p)722 (values 1 2 3)))723 (test "call-with-port returns all values yielded by proc"724 '(1 2 3)725 (list one two three)))726 (test-assert "call-with-port closes the port on normal return"727 (not (output-port-open? the-string-port)))728 (test-assert "It's ok to close output ports that are closed"729 (close-port the-string-port))730 (test-error "input-port-open? fails on output ports"731 (input-port-open? the-string-port))))))732 (test "call-with-port passes the port correctly and allows temporary escapes"733 "foobar" string)))734735 (call-with-input-string "foo"736 (lambda (the-string-port)737 (test-error "output-port-open? fails on input ports"738 (output-port-open? the-string-port))739 (test-assert "Initially, string port is open"740 (input-port-open? the-string-port))741 (test "Reading from string delivers the data"742 'foo (read the-string-port))743 (test "After reading all, we get the eof-object"744 (eof-object) (read the-string-port))745 (test-assert "Port is still open after all reads"746 (input-port-open? the-string-port))747 (close-port the-string-port)748 (test-assert "Port is no longer open after closing it"749 (not (input-port-open? the-string-port)))750 (test-assert "It's ok to close input ports that are already closed"751 (close-port the-string-port)))))752753;; This is for later. We can't define it inside a group because that754;; would make it locally scoped (as a letrec rewrite), which breaks755;; the syntax-rules underscore tests. Very subtle (and annoying), this!756(define (_) 'underscore-procedure)757(define ___ 'triple-underscore-literal)758759(test-group "syntax-rules"760 (test "let-syntax w/ basic syntax-rules"761 100762 (let-syntax ((foo (syntax-rules ()763 ((_ x form)764 (let ((tmp x))765 (if (number? tmp)766 form767 (error "not a number" tmp)))))))768 (foo 2 100)))769 (let-syntax ((foo (syntax-rules ()770 ((_ #(a ...)) (list a ...)))))771 (test "Basic matching of vectors"772 '(1 2 3) (foo #(1 2 3))))773 ;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)774 (let-syntax ((foo (syntax-rules ()775 ((_ (a b) ...)776 (list 'first '(a b) ...))777 ((_ a ...)778 (list 'second '(a) ...)))))779 (test "Basic ellipsis match"780 '(first (1 2) (3 4) (5 6)) (foo (1 2) (3 4) (5 6)))781 (test "Ellipsis match of length 1 does not match length 2"782 '(second (1)) (foo 1))783 (test "Ellipsis match of lists with mismatched lengths (used to fail)"784 '(second ((1 2)) ((3)) ((5 6))) (foo (1 2) (3) (5 6))))785786 (test "letrec-syntax"787 34788 (letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))789 (bar (syntax-rules () ((_ x) (+ x 1)))))790 (foo 33)))791 (test "Basic hygienic rename of syntactic keywords"792 'now793 (let-syntax ((when (syntax-rules ()794 ((when test stmt1 stmt2 ...)795 (if test796 (begin stmt1797 stmt2 ...))))))798 (let ((if #t))799 (when if (set! if 'now))800 if)))801 (test "Basic hygienic rename of shadowed outer let"802 'outer803 (let ((x 'outer))804 (let-syntax ((m (syntax-rules () ((m) x))))805 (let ((x 'inner))806 (m)))))807 (test "Simple recursive letrec expansion"808 7809 (letrec-syntax810 ((my-or (syntax-rules ()811 ((my-or) #f)812 ((my-or e) e)813 ((my-or e1 e2 ...)814 (let ((temp e1))815 (if temp816 temp817 (my-or e2 ...)))))))818 (let ((x #f)819 (y 7)820 (temp 8)821 (let odd?)822 (if even?))823 (my-or x824 (let temp)825 (if y)826 y))))827 ;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"828 (let ((a 1))829 (letrec-syntax830 ((foo (syntax-rules ()831 ((_ b)832 (bar a b))))833 (bar (syntax-rules ()834 ((_ c d)835 (cons c (let ((c 3))836 (list d c 'c)))))))837 (let ((a 2))838 (test "Al* Petrofsky torture test" '(1 2 3 a) (foo a)))))839 (let-syntax840 ((foo (syntax-rules ()841 ((_)842 '#(b)))))843 (test "Quoted symbols inside vectors are stripped of syntactic info"844 '#(b) (foo)))845 (let-syntax ((kw (syntax-rules (baz)846 ((_ baz) "baz")847 ((_ any) "no baz"))))848 (test "syntax-rules keywords match" "baz" (kw baz))849 (test "syntax-rules keywords no match" "no baz" (kw xxx))850 (let ((baz 100))851 (test "keyword loses meaning if shadowed" "no baz" (kw baz))))852 (test "keyword also loses meaning for builtins (from R7RS section 4.3.2)"853 'ok854 (let ((=> #f))855 (cond (#t => 'ok))))856 (test "Nested identifier shadowing works correctly"857 '(3 4)858 (let ((foo 3))859 (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))860 (let ((foo 4))861 (bar foo)))))862 (let-syntax ((c (syntax-rules ()863 ((_)864 (let ((x 10))865 (let-syntax ((z (syntax-rules ()866 ((_) (quote x)))))867 (z))))))868 (c2 (syntax-rules ()869 ((_)870 (let ((x 10))871 (let-syntax872 ((z (syntax-rules ()873 ((_) (let-syntax874 ((w (syntax-rules ()875 ((_) (quote x)))))876 (w))))))877 (z)))))))878 ;; Reported by Matthew Flatt879 (test "strip-syntax cuts across three levels of syntax"880 "x" (symbol->string (c)))881 (test "strip-syntax cuts across four levels of syntax"882 "x" (symbol->string (c2))))883 (let-syntax ((foo (syntax-rules884 ___ ()885 ((_ vals ___) (list '... vals ___)))))886 (test "Alternative ellipsis (from SRFI-46)"887 '(... 1 2 3) (foo 1 2 3)))888 (let-syntax ((let-alias (syntax-rules889 ___ ()890 ((_ new old code ___)891 (let-syntax892 ((new893 (syntax-rules ()894 ((_ args ...) (old args ...)))))895 code ___)))))896 (let-alias inc (lambda (x) (+ 1 x))897 (test "Ellipsis rules are reset in new macro expansion phase"898 3 (inc 2))))899 (let-syntax ((foo (syntax-rules ()900 ((_ (a ... b) ... (c d))901 (list (list (list a ...) ... b ...) c d))902 ((_ #(a ... b) ... #(c d) #(e f))903 (list (list (vector a ...) ... b ...) c d e f))904 ((_ #(a ... b) ... #(c d))905 (list (list (vector a ...) ... b ...) c d)))))906 (test-group "rest patterns after ellipsis (SRFI-46 smoke test)"907 (test '(() 1 2) (foo (1 2)))908 (test '(((1) 2) 3 4) (foo (1 2) (3 4)))909 (test '(((1 2) (4) 3 5) 6 7)910 (foo (1 2 3) (4 5) (6 7)))911 (test '(() 1 2)912 (foo #(1 2)))913 (test '((#() 1) 2 3)914 (foo #(1) #(2 3)))915 (test '((#(1 2) 3) 4 5)916 (foo #(1 2 3) #(4 5)))917 (test '((#(1 2) 3) 4 5 6 7)918 (foo #(1 2 3) #(4 5) #(6 7)))919 (test '(() 1 2 3 4)920 (foo #(1 2) #(3 4)))921 (test '((#(1) 2) 3 4 5 6)922 (foo #(1 2) #(3 4) #(5 6)))923 (test '((#(1 2) #(4) 3 5) 6 7 8 9)924 (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))))925 (let-syntax ((foo (syntax-rules ()926 ((_ #((a) ...)) (list a ...)))))927 (test "Bug discovered during implementation of rest patterns"928 '(1)929 (foo #((1)))))930 ;; R7RS: (<ellipsis> <template>) is like <template>, ignoring931 ;; occurrances of <ellipsis> inside the template.932 (let-syntax ((be-like-begin933 (syntax-rules ()934 ((be-like-begin name)935 (define-syntax name936 (syntax-rules ()937 ((name expr (... ...))938 (begin expr (... ...)))))))))939 (be-like-begin sequence)940 (test "be-like-begin from R7RS 4.3.2 (nested ellipsis are not expanded)"941 4 (sequence 1 2 3 4)))942 (let-syntax ((ignore-underscores943 (syntax-rules ()944 ((_ _ _ _) (_)))))945 (test "underscores are ignored in patterns"946 'underscore-procedure (ignore-underscores _ b c)))947948 (test-group "undefined behaviours: mixing keywords, ellipsis and underscores"949 (test-group "underscore as keyword literal"950 (define-syntax match-literal-underscores ; for eval951 (syntax-rules (_)952 ((x a _ c) (_))953 ((x _ b c) 1)))954 (test-error "Missing literal underscore keyword causes syntax-error"955 (eval '(match-literal-underscores d e f)))956 (test "Literal underscore matches"957 1 (match-literal-underscores _ h i))958 (test "Literal underscore matches even if it refers to toplevel binding"959 'underscore-procedure (match-literal-underscores g _ i)))960961 (test-group "underscore as ellipsis"962 ;; It's undefined what this should do. Logically, it should be963 ;; possible to bind _ as an ellipsis identifier.964 (define-syntax match-ellipsis-underscores ; for eval965 (syntax-rules _ () ((x a _ c) (list a _ c))))966 (test-error "No rule matching if prefix is omitted"967 (eval '(match-ellipsis-underscores)))968 (test "Only prefix is supplied"969 '(1) (match-ellipsis-underscores 1))970 (test "Ellipsis does its work if multiple arguments given"971 '(1 2 3 4 5 6) (match-ellipsis-underscores 1 2 3 4 5 6)))972973 (test-group "underscore as ellipsis mixed with underscore literal"974 ;; Even more undefined behaviour: mixing literals and ellipsis identifiers975 ;; Currently, ellipsis identifiers have precedence over the other two.976 (define-syntax match-ellipsis-and-literals-underscores ; for eval977 (syntax-rules _ (_) ((x a _ c) (list a _ c))))978 (test-error "No rule matching if prefix is omitted"979 (eval '(match-ellipsis-and-literals-underscores)))980 (test '(1) (match-ellipsis-and-literals-underscores 1))981 (test '(1 2 3) (match-ellipsis-and-literals-underscores 1 2 3))982 (test '(1 2 3 4 5 6) (match-ellipsis-and-literals-underscores 1 2 3 4 5 6)))983984 (test-group "\"custom\" ellipsis and literal of the same identifier"985 ;; This is similar to the above, but maybe a little simpler because986 ;; it does not use reserved names:987 (define-syntax match-ellipsis-literals988 (syntax-rules ___ (___)989 ((_ x ___) (list x ___))))990 (test "Ellipsis as literals"991 '(1) (match-ellipsis-literals 1))992 (test "Ellipsis as literals multiple args"993 '(1 2) (match-ellipsis-literals 1 2))994 (test "Toplevel binding of the same name as ellipsis"995 '(1 triple-underscore-literal) (match-ellipsis-literals 1 ___))))996997 (letrec-syntax ((usetmp998 (syntax-rules ()999 ((_ var)1000 (list var))))1001 (withtmp1002 (syntax-rules ()1003 ((_ val exp)1004 (let ((tmp val))1005 (exp tmp))))))1006 (test "Passing a macro as argument to macro"1007 '(99)1008 (withtmp 99 usetmp)))10091010 ;; renaming of keyword argument (#277)1011 (let-syntax ((let-hello-proc1012 (syntax-rules ()1013 ((_ procname code ...)1014 (let ((procname (lambda (#!key (who "world"))1015 (string-append "hello, " who))))1016 code ...)))))1017 (let-hello-proc bar1018 ;; This is not R7RS, but R7RS should not interfere with other1019 ;; CHICKEN features!1020 (test "DSSSL keyword arguments aren't renamed (not R7RS)"1021 "hello, XXX" (bar who: "XXX")))))10221023(test-group "define-record-type"1024 (define-record-type foo (make-foo) foo?)1025 (define foo1 (make-foo))1026 (test-assert "Record instances satisfy their predicates" (foo? foo1))1027 (define-record-type foo (make-foo) foo?)1028 (test-assert "Record type definitions are generative" (not (foo? foo1))))10291030(test-group "open-input-bytevector"1031 (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)1032 (let ((bv (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)))1033 (read-bytevector 12 (open-input-bytevector bv)))))10341035(test-group "open-output-bytevector"1036 (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)1037 (let ((p (open-output-bytevector)))1038 (write-bytevector (bytevector 0 1 2 10 13) p)1039 (write-bytevector (bytevector 40 41 42 128) p)1040 (write-bytevector (bytevector 140 240 255) p)1041 (close-output-port p)1042 (get-output-bytevector p))))10431044;; this was submitted as broken by Lukas Bröger:1045(test-group "eval environments"1046 (test 42 (eval '42 (scheme-report-environment 5))))10471048(test-end "r7rs tests")10491050(test-exit)