1;;;; library-tests.scm 2 3(import chicken.blob chicken.bitwise chicken.fixnum chicken.flonum 4 chicken.keyword chicken.port chicken.condition) 5 6(define-syntax assert-fail 7 (syntax-rules () 8 ((_ exp) 9 (assert (handle-exceptions ex #t exp #f))))) 10 11(define (list-tabulate n proc) 12 (let loop ((i 0)) 13 (if (fx>= i n) 14 '() 15 (cons (proc i) (loop (fx+ i 1)))))) 16 17(define (every pred lst) 18 (let loop ((lst lst)) 19 (cond ((null? lst)) 20 ((not (pred (car lst))) #f) 21 (else (loop (cdr lst)))))) 22 23;; numbers 24 25(assert (not (not 3))) 26(assert (= -4.0 (round -4.3))) 27(assert (= -4.0 (round -4.5))) ; R5RS 28(assert (= 4.0 (round 3.5))) 29(assert (= 4.0 (round 4.5))) ; R5RS 30(assert (= 4 (round (string->number "7/2")))) 31(assert (= 7 (round 7))) 32(assert (zero? (round -0.5))) ; is actually -0.0 33(assert (zero? (round -0.3))) 34(assert (= -1 (round -0.6))) 35(assert (zero? (round 0.5))) 36(assert (zero? (round 0.3))) 37(assert (= 1.0 (round 0.6))) 38(assert (rational? 1)) 39(assert (finite? 1)) 40(assert-fail (finite? 'foo)) 41(assert (rational? 1.0)) 42(assert (finite? 1.0)) 43(assert (not (rational? +inf.0))) 44(assert (not (finite? +inf.0))) 45(assert (not (rational? -inf.0))) 46(assert (not (finite? -inf.0))) 47(assert (not (rational? +nan.0))) 48(assert (not (finite? +nan.0))) 49(assert (not (rational? 'foo))) 50(assert (not (rational? "foo"))) 51(assert (integer? 2)) 52(assert (integer? 2.0)) 53(assert (not (integer? 1.1))) 54(assert (not (integer? +inf.0))) 55(assert (not (integer? -inf.0))) 56(assert (not (integer? +nan.0))) 57(assert (not (integer? 'foo))) 58(assert (not (integer? "foo"))) 59; XXX number missing 60 61;; Negative vs positive zero (see #1627) 62(assert (not (eqv? 0.0 -0.0))) 63(assert (not (equal? 0.0 -0.0))) 64(assert (= 0.0 -0.0)) 65 66(assert (not (positive? 0.0))) 67(assert (not (negative? 0.0))) 68(assert (zero? 0.0)) 69 70(assert (not (positive? -0.0))) 71(assert (not (negative? -0.0))) 72(assert (zero? -0.0)) 73 74;; Exactness 75(assert (exact? 1)) 76(assert (not (exact? 1.0))) 77(assert (not (exact? 1.1))) 78(assert-fail (exact? 'foo)) 79(assert (not (inexact? 1))) 80(assert (inexact? 1.0)) 81(assert (inexact? 1.1)) 82(assert-fail (inexact? 'foo)) 83 84;; Division by inexact zero used to fail, but now it returns +inf.0 85(assert-fail (/ 1 1 0)) 86(assert (eqv? +inf.0 (/ 1 1 0.0))) 87(assert (eqv? +inf.0 (/ 1 0.0))) 88(assert-fail (/ 1 0)) 89(assert-fail (/ 0)) 90(assert (eqv? +inf.0 (/ 0.0))) 91 92(assert (fixnum? (/ 1))) 93 94(assert (= -3 (- 3))) 95(assert (= 3 (- -3))) 96(assert (= 2 (- 5 3))) 97(assert (> 1 (/ 3))) 98(assert (> 1 (/ 3.0))) 99(assert (= 2 (/ 8 4))) 100(assert (zero? (+))) 101(assert (= 1 (*))) 102 103(assert (= 2.5 (/ 5 2))) 104 105;; Use equal? instead of = to check equality and exactness in one go 106(assert (equal? 0 (numerator 0))) 107(assert (equal? 1 (denominator 0))) 108(assert (equal? 3 (numerator 3))) 109(assert (equal? 1 (denominator 3))) 110(assert (equal? -3 (numerator -3))) 111(assert (equal? 1 (denominator -3))) 112(assert (equal? 1.0 (numerator 0.5))) 113(assert (equal? 2.0 (denominator 0.5))) 114(assert (equal? 5.0 (numerator 1.25))) 115(assert (equal? 4.0 (denominator 1.25))) 116(assert (equal? -5.0 (numerator -1.25))) 117 118;;; A few denormalised numbers, cribbed from NetBSD ATF tests for ldexp(): 119;; On some machines/OSes these tests fail due to missing hardware support 120;; and sometimes due to broken libc/libm support, so we have disabled them. 121;(assert (equal? 1.0 (numerator 1.1125369292536006915451e-308))) 122;(assert (equal? +inf.0 (denominator 1.1125369292536006915451e-308))) 123;(assert (equal? -1.0 (numerator -5.5626846462680034577256e-309))) 124;(assert (equal? +inf.0 (denominator -5.5626846462680034577256e-309))) 125;(assert (equal? 1.0 (numerator 4.9406564584124654417657e-324))) 126;(assert (equal? +inf.0 (denominator 4.9406564584124654417657e-324))) 127 128(assert (equal? 4.0 (denominator -1.25))) 129(assert (equal? 1e10 (numerator 1e10))) 130(assert (equal? 1.0 (denominator 1e10))) 131(assert-fail (numerator +inf.0)) 132(assert-fail (numerator +nan.0)) 133(assert-fail (denominator +inf.0)) 134(assert-fail (denominator +nan.0)) 135 136(assert (even? 2)) 137(assert (even? 2.0)) 138(assert (even? 0)) 139(assert (even? 0.0)) 140(assert (not (even? 3))) 141(assert (not (even? 3.0))) 142(assert (odd? 1)) 143(assert (odd? 1.0)) 144(assert (not (odd? 0))) 145(assert (not (odd? 0.0))) 146(assert (not (odd? 2))) 147(assert (not (odd? 2.0))) 148(assert-fail (even? 1.2)) 149(assert-fail (odd? 1.2)) 150(assert-fail (even? +inf.0)) 151(assert-fail (odd? +inf.0)) 152(assert-fail (even? +nan.0)) 153(assert-fail (odd? +nan.0)) 154(assert-fail (even? 'x)) 155(assert-fail (odd? 'x)) 156 157(assert (= 60 (arithmetic-shift 15 2))) 158(assert (= 3 (arithmetic-shift 15 -2))) 159(assert (= -60 (arithmetic-shift -15 2))) 160(assert (= -4 (arithmetic-shift -15 -2))) ; 2's complement 161(assert-fail (arithmetic-shift 0.1 2)) 162;; XXX Do the following two need to fail? Might as well use the integral value 163(assert-fail (arithmetic-shift #xf 2.0)) 164(assert-fail (arithmetic-shift #xf -2.0)) 165(assert-fail (arithmetic-shift #xf 2.1)) 166(assert-fail (arithmetic-shift #xf -2.1)) 167(assert-fail (arithmetic-shift +inf.0 2)) 168(assert-fail (arithmetic-shift +nan.0 2)) 169 170(assert (= 0 (gcd))) 171(assert (= 6 (gcd 6))) 172(assert (= 2 (gcd 6 8))) 173(assert (= 1 (gcd 6 8 5))) 174(assert (= 1 (gcd 6 -8 5))) 175(assert (= 2.0 (gcd 6.0 8.0))) 176(assert-fail (gcd 6.1 8.0)) 177(assert-fail (gcd 6.0 8.1)) 178(assert-fail (gcd +inf.0)) 179(assert-fail (gcd +nan.0)) 180(assert-fail (gcd 6.0 +inf.0)) 181(assert-fail (gcd +inf.0 6.0)) 182(assert-fail (gcd +nan.0 6.0)) 183(assert-fail (gcd 6.0 +nan.0)) 184 185(assert (= 1 (lcm))) 186(assert (= 6 (lcm 6))) 187(assert (= 24 (lcm 6 8))) 188(assert (= 120 (lcm 6 8 5))) 189(assert (= 24.0 (lcm 6.0 8.0))) 190(assert-fail (lcm +inf.0)) 191(assert-fail (lcm +nan.0)) 192(assert-fail (lcm 6.1 8.0)) 193(assert-fail (lcm 6.0 8.1)) 194(assert-fail (lcm 6.0 +inf.0)) 195(assert-fail (lcm +inf.0 6.0)) 196(assert-fail (lcm +nan.0 6.0)) 197(assert-fail (lcm 6.0 +nan.0)) 198 199(assert (= 3 (quotient 13 4))) 200(assert (= 3.0 (quotient 13.0 4.0))) 201(assert-fail (quotient 13.0 4.1)) 202(assert-fail (quotient 13.2 4.0)) 203(assert-fail (quotient +inf.0 4.0)) 204(assert-fail (quotient +nan.0 4.0)) 205(assert-fail (quotient 4.0 +inf.0)) 206(assert-fail (quotient 4.0 +nan.0)) 207 208(assert (= 1 (remainder 13 4))) 209(assert (= 1.0 (remainder 13.0 4.0))) 210(assert-fail (remainder 13.0 4.1)) 211(assert-fail (remainder 13.2 4.0)) 212(assert-fail (remainder +inf.0 4.0)) 213(assert-fail (remainder +nan.0 4.0)) 214(assert-fail (remainder 4.0 +inf.0)) 215(assert-fail (remainder 4.0 +nan.0)) 216 217(assert (= 1 (modulo 13 4))) 218(assert (= 1.0 (modulo 13.0 4.0))) 219(assert-fail (modulo 13.0 4.1)) 220(assert-fail (modulo 13.2 4.0)) 221(assert-fail (modulo +inf.0 4.0)) 222(assert-fail (modulo +nan.0 4.0)) 223(assert-fail (modulo 4.0 +inf.0)) 224(assert-fail (modulo 4.0 +nan.0)) 225 226(assert-fail (min 'x)) 227(assert-fail (max 'x)) 228(assert (eq? 1 (min 1 2))) 229(assert (eq? 1 (min 2 1))) 230(assert (eq? 2 (max 1 2))) 231(assert (eq? 2 (max 2 1))) 232;; must be flonum 233(assert (fp= 1.0 (min 1 2.0))) 234(assert (fp= 1.0 (min 2.0 1))) 235(assert (fp= 2.0 (max 2 1.0))) 236(assert (fp= 2.0 (max 1.0 2))) 237 238;; number->string conversion 239 240(for-each 241 (lambda (x) 242 (let ((number (car x)) 243 (radix (cadr x))) 244 (assert (eqv? number (string->number (number->string number radix) radix))))) 245 '((123 10) 246 (123 2) 247 (123 8) 248 (-123 10) 249 (-123 2) 250 (-123 8) 251 (99.2 10) 252 (-99.2 10))) 253 254;; by Christian Kellermann 255(assert 256 (equal? 257 (map (lambda (n) (number->string 32 n)) (list-tabulate 15 (cut + 2 <>))) 258 '("100000" "1012" "200" "112" "52" "44" "40" "35" "32" "2a" "28" "26" "24" "22" "20"))) 259 260;; #1422 261(assert (equal? (map + '(1 2 3) '(1 2)) '(2 4))) 262(assert (equal? (map + '(1 2) '(1 2 3)) '(2 4))) 263(let ((result '())) 264 (for-each (lambda (x y) (set! result (cons (+ x y) result))) 265 '(1 2) '(1 2 3)) 266 (assert (equal? result '(4 2)))) 267(let ((result '())) 268 (for-each (lambda (x y) (set! result (cons (+ x y) result))) 269 '(1 2 3) '(1 2)) 270 (assert (equal? result '(4 2)))) 271 272;; string->number conversion 273 274(assert (= 255 (string->number "ff" 16))) 275(assert (not (string->number "fg" 16))) 276 277 278;; fp-math 279 280(define (inexact= a b) 281 (< (abs (- 1 (abs (/ a b)))) 1e-10)) 282 283(assert (inexact= (sin 42.0) (fpsin 42.0))) 284(assert (inexact= (cos 42.0) (fpcos 42.0))) 285(assert (inexact= (tan 42.0) (fptan 42.0))) 286(assert (inexact= (asin 0.5) (fpasin 0.5))) 287(assert (inexact= (acos 0.5) (fpacos 0.5))) 288(assert (inexact= (atan 0.5) (fpatan 0.5))) 289(assert (inexact= (atan 42.0 1.2) (fpatan2 42.0 1.2))) 290(assert (inexact= (atan 42.0 1) (fpatan2 42.0 1.0))) 291(assert (inexact= (atan 42 1.0) (fpatan2 42.0 1.0))) 292(assert (inexact= (exp 42.0) (fpexp 42.0))) 293(assert (inexact= (log 42.0) (fplog 42.0))) 294(assert (inexact= (expt 42.0 3.5) (fpexpt 42.0 3.5))) 295(assert (inexact= (sqrt 42.0) (fpsqrt 42.0))) 296(assert (inexact= 43.0 (fpround 42.5))) 297(assert (inexact= -43.0 (fpround -42.5))) 298(assert (inexact= 42.0 (fpround 42.2))) 299(assert (inexact= 42.0 (fptruncate 42.5))) 300(assert (inexact= -42.0 (fptruncate -42.5))) 301(assert (inexact= 42.0 (fpfloor 42.2))) 302(assert (inexact= -43.0 (fpfloor -42.5))) 303(assert (inexact= 43.0 (fpceiling 42.5))) 304(assert (inexact= -42.0 (fpceiling -42.2))) 305(assert (not (fpinteger? 2.3))) 306(assert (fpinteger? 1.0)) 307 308;; string->symbol 309 310;; by Jim Ursetto 311(assert 312 (eq? '|3| 313 (with-input-from-string 314 (with-output-to-string 315 (lambda () 316 (write (string->symbol "3")))) 317 read))) 318 319;;; escaped symbol syntax 320 321(assert (string=? "abc" (symbol->string '|abc|))) 322(assert (string=? "abcdef" (symbol->string '|abc||def|))) 323(assert (string=? "abcxyzdef" (symbol->string '|abc|xyz|def|))) 324(assert (string=? "abc|def" (symbol->string '|abc\|def|))) 325(assert (string=? "abc|def" (symbol->string '|abc\|def|))) 326(assert (string=? "abc" (symbol->string 'abc))) 327(assert (string=? "a c" (symbol->string 'a\ c))) 328(assert (string=? "aBc" (symbol->string 'aBc))) 329 330(parameterize ((case-sensitive #f)) 331 (assert (string=? "abc" (symbol->string (with-input-from-string "aBc" read)))) 332 (assert (string=? "aBc" (symbol->string (with-input-from-string "|aBc|" read)))) 333 (assert (string=? "aBc" (symbol->string (with-input-from-string "a\\Bc" read))))) 334 335(parameterize ((symbol-escape #f)) 336 (assert (string=? "aBc" (symbol->string (with-input-from-string "aBc" read)))) 337 (assert-fail (with-input-from-string "|aBc|" read)) 338 (assert-fail (with-input-from-string "a|Bc" read))) 339(parameterize ((symbol-escape #t)) 340 (assert (string=? "aBc" (symbol->string (with-input-from-string "aBc" read)))) 341 (assert (string=? "aBc" (symbol->string (with-input-from-string "|aBc|" read)))) 342 (assert (string=? "aB c" (symbol->string (with-input-from-string "|aB c|" read)))) 343 ;; The following is an extension/generalisation of r7RS 344 (assert (string=? "aBc" (symbol->string (with-input-from-string "a|Bc|" read)))) 345 ;; "Unterminated string" (unterminated identifier?) 346 (assert-fail (with-input-from-string "a|Bc" read))) 347 348;;; Old style qualified low byte, see #1077 349 350(assert (string=? "##foo#bar" (symbol->string '|##foo#bar|))) 351(assert (string=? "##foo#bar" (symbol->string '##foo#bar))) 352(assert (eq? '##foo#bar '|##foo#bar|)) 353 354(assert (string=? "|\\x0a|" (with-output-to-string (lambda () (write '|\n|))))) 355;; #1576 356(assert (string=? "|\\x00foo|" (with-output-to-string (lambda () (write '|\000foo|))))) 357(assert (not (keyword? '|\000foo|))) 358(assert (string=? "|###foo#bar|" (with-output-to-string (lambda () (write '|###foo#bar|))))) 359 360;;; Paren synonyms 361 362(parameterize ((parentheses-synonyms #f)) 363 (assert (eq? '() (with-input-from-string "()" read))) 364 (assert-fail (with-input-from-string "[]" read)) 365 (assert-fail (with-input-from-string "{}" read))) 366(parameterize ((parentheses-synonyms #t)) 367 (assert (eq? '() (with-input-from-string "()" read))) 368 (assert (eq? '() (with-input-from-string "[]" read))) 369 (assert (eq? '() (with-input-from-string "{}" read)))) 370 371;;; keywords 372 373(parameterize ((keyword-style #:suffix)) 374 (assert (string=? "abc:" (symbol->string (with-input-from-string "|abc:|" read)))) 375 (assert (string=? "abc" (keyword->string (with-input-from-string "|abc|:" read)))) ; keyword 376 (let ((kw (with-input-from-string "|foo bar|:" read)) 377 (sym1 (with-input-from-string "|foo:|" read)) 378 (sym2 (with-input-from-string "|:foo|" read))) 379 380 (assert (symbol? sym1)) 381 (assert (not (keyword? sym1))) 382 383 (assert (symbol? sym2)) 384 (assert (not (keyword? sym2))) 385 386 (assert (keyword? kw)) 387 (assert (not (symbol? kw))) 388 389 (assert (eq? kw (with-input-from-string "#:|foo bar|" read))) 390 (assert (string=? "foo bar" (keyword->string kw))) 391 (assert (string=? "foo:" (symbol->string sym1))) 392 (assert (string=? ":foo" (symbol->string sym2))) 393 394 (assert (string=? "foo bar:" 395 (with-output-to-string (lambda () (display kw))))) 396 (assert (string=? "#:|foo bar|" 397 (with-output-to-string (lambda () (write kw))))) 398 399 (assert (string=? "|foo:|" 400 (with-output-to-string (lambda () (write sym1))))) 401 ;; Regardless of keyword style, symbols must be quoted to avoid 402 ;; issues when reading it back with a different keyword style. 403 (assert (string=? "|:foo|" 404 (with-output-to-string (lambda () (write sym2))))))) 405 406(parameterize ((keyword-style #:prefix)) 407 (assert (string=? "abc" (keyword->string (with-input-from-string ":|abc|" read)))) 408 (assert (string=? ":abc" (symbol->string (with-input-from-string "|:abc|" read)))) 409 (let ((kw (with-input-from-string ":|foo bar|" read)) 410 (sym1 (with-input-from-string "|:foo|" read)) 411 (sym2 (with-input-from-string "|foo:|" read))) 412 413 (assert (symbol? sym1)) 414 (assert (not (keyword? sym1))) 415 416 (assert (symbol? sym2)) 417 (assert (not (keyword? sym2))) 418 419 (assert (keyword? kw)) 420 (assert (not (symbol? kw))) 421 422 (assert (eq? kw (with-input-from-string "#:|foo bar|" read))) 423 (assert (string=? "foo bar" (keyword->string kw))) 424 (assert (string=? ":foo" (symbol->string sym1))) 425 (assert (string=? "foo:" (symbol->string sym2))) 426 427 (assert (string=? ":foo bar" 428 (with-output-to-string (lambda () (display kw))))) 429 (assert (string=? "#:|foo bar|" 430 (with-output-to-string (lambda () (write kw))))) 431 432 (assert (string=? "|:foo|" 433 (with-output-to-string (lambda () (write sym1))))) 434 ;; Regardless of keyword style, symbols must be quoted to avoid 435 ;; issues when reading it back with a different keyword style. 436 (assert (string=? "|foo:|" 437 (with-output-to-string (lambda () (write sym2))))))) 438 439(parameterize ((keyword-style #:none)) 440 (let ((kw (with-input-from-string "#:|foo bar|" read)) 441 (sym1 (with-input-from-string "|:foo|" read)) 442 (sym2 (with-input-from-string "|foo:|" read))) 443 444 (assert (symbol? sym1)) 445 (assert (not (keyword? sym1))) 446 447 (assert (symbol? sym2)) 448 (assert (not (keyword? sym2))) 449 450 (assert (keyword? kw)) 451 (assert (not (symbol? kw))) 452 453 (assert (eq? kw (string->keyword "foo bar")) 454 (assert (string=? "foo bar" (keyword->string kw))) 455 (assert (string=? ":foo" (symbol->string sym1))) 456 (assert (string=? "foo:" (symbol->string sym2))) 457 458 (assert (string=? ":foo" 459 (with-output-to-string (lambda () (display kw))))) 460 (assert (string=? "#:|foo bar|" 461 (with-output-to-string (lambda () (write kw))))) 462 463 ;; Regardless of keyword style, symbols must be quoted to avoid 464 ;; issues when reading it back with a different keyword style. 465 (assert (string=? "|:foo|" 466 (with-output-to-string (lambda () (write sym1))))) 467 (assert (string=? "|foo:|" 468 (with-output-to-string (lambda () (write sym2)))))))) 469 470(assert (eq? '|#:| (string->symbol "#:"))) 471(assert-fail (with-input-from-string "#:" read)) ; empty keyword 472(assert (eq? '|#:| (with-input-from-string (with-output-to-string (cut write '|#:|)) read))) 473 474(parameterize ((keyword-style #:suffix)) 475 (assert (keyword? (with-input-from-string "abc:" read))) 476 (assert (keyword? (with-input-from-string "|abc|:" read))) 477 (assert (keyword? (with-input-from-string "a|bc|d:" read))) 478 (assert (not (keyword? (with-input-from-string "abc:||" read)))) 479 (assert (not (keyword? (with-input-from-string "abc\\:" read)))) 480 (assert (not (keyword? (with-input-from-string "abc|:|" read)))) 481 (assert (not (keyword? (with-input-from-string "|abc:|" read))))) 482 483(parameterize ((keyword-style #:prefix)) 484 (assert (keyword? (with-input-from-string ":abc" read))) 485 (assert (keyword? (with-input-from-string ":|abc|" read))) 486 (assert (keyword? (with-input-from-string ":a|bc|d" read))) 487 (assert (not (keyword? (with-input-from-string "||:abc" read)))) 488 (assert (not (keyword? (with-input-from-string "\\:abc" read)))) 489 (assert (not (keyword? (with-input-from-string "|:|abc" read)))) 490 (assert (not (keyword? (with-input-from-string "|:abc|" read))))) 491 492(parameterize ((keyword-style #f)) 493 (assert (not (keyword? (with-input-from-string ":||" read)))) 494 (assert (not (keyword? (with-input-from-string "||:" read)))) 495 (assert (not (keyword? (with-input-from-string ":abc" read)))) 496 (assert (not (keyword? (with-input-from-string ":abc:" read)))) 497 (assert (not (keyword? (with-input-from-string "abc:" read))))) 498 499(parameterize ((keyword-style #:suffix)) 500 (let ((colon-sym (with-input-from-string ":" read))) 501 (assert (symbol? colon-sym)) 502 (assert (not (keyword? colon-sym))) 503 (assert (string=? ":" (symbol->string colon-sym))))) 504 505(parameterize ((keyword-style #:prefix)) 506 (let ((colon-sym (with-input-from-string ":" read))) 507 (assert (symbol? colon-sym)) 508 (assert (not (keyword? colon-sym))) 509 (assert (string=? ":" (symbol->string colon-sym))))) 510 511;; The next two cases are a bit dubious, but we follow SRFI-88 (see 512;; also #1625). 513(parameterize ((keyword-style #:suffix)) 514 (let ((colon-sym (with-input-from-string ":||" read))) 515 (assert (symbol? colon-sym)) 516 (assert (not (keyword? colon-sym))) 517 (assert (string=? ":" (symbol->string colon-sym)))) 518 519 (let ((empty-kw (with-input-from-string "||:" read))) 520 (assert (not (symbol? empty-kw))) 521 (assert (keyword? empty-kw)) 522 (assert (string=? "" (keyword->string empty-kw))))) 523 524(parameterize ((keyword-style #:prefix)) 525 (let ((empty-kw (with-input-from-string ":||" read))) 526 (assert (not (symbol? empty-kw))) 527 (assert (keyword? empty-kw)) 528 (assert (string=? "" (keyword->string empty-kw)))) 529 530 (let ((colon-sym (with-input-from-string "||:" read))) 531 (assert (symbol? colon-sym)) 532 (assert (not (keyword? colon-sym))) 533 (assert (string=? ":" (symbol->string colon-sym))))) 534 535(assert-fail (with-input-from-string "#:" read)) 536 537(let ((empty-kw (with-input-from-string "#:||" read))) 538 (assert (not (symbol? empty-kw))) 539 (assert (keyword? empty-kw)) 540 (assert (string=? "" (keyword->string empty-kw)))) 541 542;; TODO: It should eventually be possible to distinguish these (#1077) 543#;(let ((nul-sym (with-input-from-string "|\\x00|" read))) 544 (assert (not (keyword? nul-sym))) 545 (assert (string=? "\x00" (symbol->string nul-sym)))) 546 547(assert (keyword? (with-input-from-string "42:" read))) 548(assert (keyword? (with-input-from-string ".:" read))) 549 550(assert (equal? (cons 1 2) (with-input-from-string "(1 . 2)" read))) 551(assert (every keyword? (with-input-from-string "(42: abc: .: #:: ::)" read))) 552 553;; symbols and keywords are now distinct 554(assert (not (symbol? #:foo))) 555(assert (not (symbol? (string->keyword "foo")))) 556(assert (not (keyword? 'foo))) 557(assert (not (keyword? (string->symbol "foo")))) 558 559;;; reading unterminated objects 560 561(assert-fail (with-input-from-string "(" read)) 562(assert-fail (with-input-from-string "(1 . 2" read)) 563(assert-fail (with-input-from-string "|" read)) 564(assert-fail (with-input-from-string "\"" read)) 565(assert-fail (with-input-from-string "#|" read)) 566(assert-fail (with-input-from-string "#(" read)) 567(assert-fail (with-input-from-string "#${" read)) 568(assert-fail (with-input-from-string "\\" read)) 569(assert-fail (with-input-from-string "|\\" read)) 570(assert-fail (with-input-from-string "\"\\" read)) 571 572;;; here documents 573 574(assert (string=? "" #<<A 575A 576)) 577 578(assert (string=? "foo" #<<A 579foo 580A 581)) 582 583(assert (string=? "\nfoo\n" #<<A 584 585foo 586 587A 588)) 589 590(assert (string=? "foo\nbar\nbaz" #<<A 591foo 592bar 593baz 594A 595)) 596 597;;; setters 598 599(define x '(a b c)) 600(define kar car) 601(set! (kar (cdr x)) 99) 602(assert (equal? '(a 99 c) x)) 603(define p (make-parameter 100)) 604(assert (= 100 (p))) 605(set! (p) 1000) 606(assert (= 1000 (p))) 607 608 609;;; blob-literal syntax 610 611(assert (equal? '#${a} '#${0a})) 612(assert (equal? '#${ab cd} '#${abcd})) 613(assert (equal? '#${ab c} '#${ab0c})) 614(assert (equal? '#${abc} '#${ab0c})) 615(assert (equal? '#${a b c} '#${0a0b0c})) 616 617;; self-evaluating 618(assert (equal? '#${a} #${a})) 619(assert (equal? '#${abcd} #${abcd})) 620(assert (equal? '#${abc} #${abc})) 621 622 623;; #808: blobs and strings with embedded nul bytes should not be compared 624;; with ASCIIZ string comparison functions 625(assert (equal? '#${a b 0 c} '#${a b 0 c})) 626(assert (blob=? '#${a b 0 c} '#${a b 0 c})) 627(assert (equal=? "foo\x00a" "foo\x00a")) 628(assert (string=? "foo\x00a" "foo\x00a")) 629(assert (string-ci=? "foo\x00a" "foo\x00a")) 630(assert (string-ci=? "foo\x00a" "foo\x00A")) 631(assert (not (equal? '#${a b 0 c} '#${a b 0 d}))) 632(assert (not (blob=? '#${a b 0 c} '#${a b 0 d}))) 633(assert (not (equal=? "foo\x00a" "foo\x00b"))) 634(assert (not (string=? "foo\x00a" "foo\x00b"))) 635(assert (not (string-ci=? "foo\x00a" "foo\x00b"))) 636(assert (string<? "foo\x00a" "foo\x00b")) 637(assert (string>? "foo\x00b" "foo\x00a")) 638(assert (string-ci<? "foo\x00a" "foo\x00B")) 639(assert (string-ci>? "foo\x00b" "foo\x00A")) 640 641;; reported by Nils Holm (#1534) 642;; https://groups.google.com/group/comp.lang.scheme/t/6b8be06b84b39a7 643(assert (not (string-ci<=? "test" "tes"))) 644(assert (string-ci>=? "test" "tes")) 645 646 647;;; getter-with-setter 648 649(define foo 650 (let ((m 2)) 651 (getter-with-setter 652 (lambda (x) (* x m)) 653 (lambda (x) 654 (set! m x))))) 655 656(assert (= 6 (foo 3))) 657(set! (foo) 4) 658(assert (= 20 (foo 5))) 659 660(define bar 661 (getter-with-setter 662 foo 663 (lambda (x) 664 (+ x 99)))) 665 666(assert (= 12 (bar 3))) 667(assert (= 100 (set! (bar) 1))) 668(assert (= 12 (foo 3))) 669 670 671;;; equal=? 672 673(assert (not (equal=? 1 2))) 674(assert (equal=? 1 1)) 675(assert (equal=? 1 1.0)) 676(assert (not (equal=? 1 1.2))) 677(assert (equal=? 1.0 1)) 678(assert (equal=? '#(1) '#(1.0))) 679(assert (not (equal=? 'a "a"))) 680(assert (equal=? "abc" "abc")) 681(assert (equal=? '(1 2.0 3) '(1 2 3))) 682(assert (equal=? '#(1 2.0 3) '#(1 2 3))) 683(assert (equal=? '#(1 2 (3)) '#(1 2 (3)))) 684(assert (not (equal=? '#(1 2 (4)) '#(1 2 (3))))) 685(assert (not (equal=? 123 '(123)))) 686 687;;; parameters 688 689(define guard-called 0) 690 691(define p 692 (make-parameter 693 1 694 (lambda (x) 695 (set! guard-called (+ guard-called 1)) 696 x))) 697 698(define k 699 (parameterize ((p 2)) 700 (call/cc 701 (lambda (k) 702 (assert (= 2 (p))) 703 k)))) 704 705(and k (k #f)) 706 707(assert (= 2 guard-called)) 708 709;; Parameters are reset correctly (#1227, pointed out by Joo ChurlSoo) 710 711(let ((a (make-parameter 1 number->string)) 712 (b (make-parameter 2 number->string))) 713 (assert (equal? (list "1" "2") (list (a) (b)))) 714 715 (assert (equal? (list "10" "20") 716 (parameterize ((a 10) (b 20)) (list (a) (b))))) 717 718 (assert (equal? (list "1" "2") (list (a) (b)))) 719 720 (handle-exceptions exn #f (parameterize ((a 10) (b 'x)) (void))) 721 722 (assert (equal? (list "1" "2") (list (a) (b)))) 723 724 (parameterize ((a 10) (b 30) (a 20)) 725 (assert (equal? (list "20" "30") (list (a) (b))))) 726 727 (assert (equal? (list "1" "2") (list (a) (b)))) ) 728 729;; Special-cased parameters are reset correctly (#1285, regression 730;; caused by fix for #1227) 731 732(let ((original-input (current-input-port)) 733 (original-output (current-output-port)) 734 (original-error (current-error-port)) 735 (original-exception-handler (current-exception-handler))) 736 (call-with-output-string 737 (lambda (out) 738 (call-with-input-string 739 "foo" 740 (lambda (in) 741 (parameterize ((current-output-port out) 742 (current-error-port out) 743 (current-input-port in) 744 (current-exception-handler list)) 745 (display "bar") 746 (display "!" (current-error-port)) 747 (assert (equal? (read) 'foo)) 748 (assert (equal? (get-output-string out) "bar!")) 749 (assert (equal? (signal 'baz) '(baz)))))))) 750 (assert (equal? original-input (current-input-port))) 751 (assert (equal? original-output (current-output-port))) 752 (assert (equal? original-error (current-error-port))) 753 (assert (equal? original-exception-handler (current-exception-handler)))) 754 755;; Re-entering dynamic extent of a parameterize should not reset to 756;; original outer values but remember values when jumping out (another 757;; regression due to #1227, pointed out by Joo ChurlSoo in #1336). 758 759(let ((f (make-parameter 'a)) 760 (path '()) 761 (g (make-parameter 'g)) 762 (c #f)) 763 (let ((add (lambda () (set! path (cons (f) path))))) 764 (add) 765 (parameterize ((f 'b) 766 (g (call-with-current-continuation 767 (lambda (c0) (set! c c0) 'c)))) 768 (add) (f (g)) (add)) 769 (f 'd) 770 (add) 771 (if (< (length path) 8) 772 (c 'e) 773 (assert (equal? '(a b c d b e d b e d) (reverse path)))))) 774 775(let ((f (make-parameter 'a)) 776 (path '()) 777 (g (make-parameter 'g)) 778 (c #f)) 779 (let ((add (lambda () (set! path (cons (f) path))))) 780 (add) 781 (parameterize ((f 'b)) 782 (g (call-with-current-continuation (lambda (c0) (set! c c0) 'c))) 783 (add) (f (g)) (add)) 784 (f 'd) 785 (add) 786 (if (< (length path) 8) 787 (c 'e) 788 (assert (equal? '(a b c d c e d e e d) (reverse path)))))) 789 790;;; vector and blob limits 791 792(assert-fail (make-blob -1)) 793(assert-fail (make-vector -1)) 794 795;;; Resizing of vectors works to both sides 796(let ((original (vector 1 2 3 4 5 6))) 797 (assert (equal? (vector-resize original 6 -1) original)) 798 (assert (not (eq? (vector-resize original 6 -1) original)))) 799 800(let ((original (vector 1 2 3 4 5 6)) 801 (smaller (vector 1 2 3))) 802 (assert (equal? (vector-resize original 3 -1) smaller))) 803 804(let ((original (vector 1 2 3)) 805 (larger (vector 1 2 3 -1 -1 -1))) 806 (assert (equal? (vector-resize original 6 -1) larger))) 807 808;;; eval return values 809 810(assert (= 1 (eval 1))) 811(assert (eq? '() (receive (eval '(values))))) 812(assert (equal? '(1 2 3) (receive (eval '(values 1 2 3))))) 813 814;;; message checks for invalid strings 815 816(assert-fail (##sys#message "123\x00456")) 817 818;;; vector procedures 819 820(assert (equal? '#(2 3) (subvector '#(1 2 3) 1))) 821(assert (equal? '#(2) (subvector '#(1 2 3) 1 2))) 822(assert (equal? '#() (subvector '#(1 2 3) 1 1))) 823(assert (equal? '#() (subvector '#(1 2 3) 3))) 824(assert-fail (subvector '#(1 2 3) 4)) 825(assert-fail (subvector '#(1 2 3) 3 4)) 826 827;;; alist accessors 828 829(assert (equal? '(foo) (assq 'foo '((foo))))) 830(assert (not (assq 'foo '()))) 831(assert-fail (assq 'foo '(bar))) 832(assert-fail (assq 'foo 'bar)) 833 834 835(assert (equal? '(foo) (assv 'foo '((foo))))) 836(assert (not (assv 'foo '()))) 837(assert-fail (assv 'foo '(bar))) 838(assert-fail (assv 'foo 'bar)) 839 840(assert (equal? '("foo") (assoc "foo" '(("foo"))))) 841(assert (not (assoc "foo" '()))) 842(assert-fail (assoc "foo" '("bar"))) 843(assert-fail (assoc "foo" "bar")) 844 845;;; list membership 846 847(assert (equal? '(foo) (memq 'foo '(bar foo)))) 848(assert (not (memq 'foo '(bar)))) 849(assert (not (memq 'foo '()))) 850(assert-fail (memq 'foo 'foo)) 851 852(assert (equal? '(foo) (memv 'foo '(bar foo)))) 853(assert (not (memv 'foo '(bar)))) 854(assert (not (memv 'foo '()))) 855(assert-fail (memv 'foo 'foo)) 856 857(assert (equal? '("foo") (member "foo" '("bar" "foo")))) 858(assert (not (member "foo" '("bar")))) 859(assert (not (member "foo" '()))) 860(assert-fail (member "foo" "foo")) 861 862;; length 863 864(assert-fail (length 1)) 865(assert-fail (length '(x . y))) 866