module/ice-9/test.scm

   1 ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2006 Free Software Foundation, Inc.
   2 ;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 3 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16
  17 ;;;; "test.scm" Test correctness of scheme implementations.
  18 ;;; Author: Aubrey Jaffer
  19 ;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately
  20 ;;; won't pass.  Made the tests (test-cont), (test-sc4), and
  21 ;;; (test-delay) start to run automatically.
  22
  23 ;;; This includes examples from
  24 ;;; William Clinger and Jonathan Rees, editors.
  25 ;;; Revised^4 Report on the Algorithmic Language Scheme
  26 ;;; and the IEEE specification.
  27
  28 ;;; The input tests read this file expecting it to be named
  29 ;;; "test.scm", so you'll have to run it from the ice-9 source
  30 ;;; directory, or copy this file elsewhere
  31 ;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
  32 ;;; these tests.  You may need to delete them in order to run
  33 ;;; "test.scm" more than once.
  34
  35 ;;;   There are three optional tests:
  36 ;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
  37 ;;;
  38 ;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
  39 ;;;
  40 ;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
  41 ;;;   either standard.
  42
  43 ;;; If you are testing a R3RS version which does not have `list?' do:
  44 ;;; (define list? #f)
  45
  46 ;;; send corrections or additions to jaffer@ai.mit.edu or
  47 ;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
  48
  49 (define cur-section '())(define errs '())
  50 (define SECTION (lambda args
  51                   (display "SECTION") (write args) (newline)
  52                   (set! cur-section args) #t))
  53 (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
  54
  55 (define test
  56   (lambda (expect fun . args)
  57     (write (cons fun args))
  58     (display "  ==> ")
  59     ((lambda (res)
  60       (write res)
  61       (newline)
  62       (cond ((not (equal? expect res))
  63              (record-error (list res expect (cons fun args)))
  64              (display " BUT EXPECTED ")
  65              (write expect)
  66              (newline)
  67              #f)
  68             (else #t)))
  69      (if (procedure? fun) (apply fun args) (car args)))))
  70 (define (report-errs)
  71   (newline)
  72   (if (null? errs) (display "Passed all tests")
  73       (begin
  74         (display "errors were:")
  75         (newline)
  76         (display "(SECTION (got expected (call)))")
  77         (newline)
  78         (for-each (lambda (l) (write l) (newline))
  79                   errs)))
  80   (newline))
  81
  82 (SECTION 2 1);; test that all symbol characters are supported.
  83 '(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
  84
  85 (SECTION 3 4)
  86 (define disjoint-type-functions
  87   (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
  88 (define type-examples
  89   (list
  90    #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
  91 (define i 1)
  92 (for-each (lambda (x) (display (make-string i #\ ))
  93                   (set! i (+ 3 i))
  94                   (write x)
  95                   (newline))
  96           disjoint-type-functions)
  97 (define type-matrix
  98   (map (lambda (x)
  99          (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
 100            (write t)
 101            (write x)
 102            (newline)
 103            t))
 104        type-examples))
 105 (SECTION 4 1 2)
 106 (test '(quote a) 'quote (quote 'a))
 107 (test '(quote a) 'quote ''a)
 108 (SECTION 4 1 3)
 109 (test 12 (if #f + *) 3 4)
 110 (SECTION 4 1 4)
 111 (test 8 (lambda (x) (+ x x)) 4)
 112 (define reverse-subtract
 113   (lambda (x y) (- y x)))
 114 (test 3 reverse-subtract 7 10)
 115 (define add4
 116   (let ((x 4))
 117     (lambda (y) (+ x y))))
 118 (test 10 add4 6)
 119 (test '(3 4 5 6) (lambda x x) 3 4 5 6)
 120 (test '(5 6) (lambda (x y . z) z) 3 4 5 6)
 121 (SECTION 4 1 5)
 122 (test 'yes 'if (if (> 3 2) 'yes 'no))
 123 (test 'no 'if (if (> 2 3) 'yes 'no))
 124 (test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
 125 (SECTION 4 1 6)
 126 (define x 2)
 127 (test 3 'define (+ x 1))
 128 (set! x 4)
 129 (test 5 'set! (+ x 1))
 130 (SECTION 4 2 1)
 131 (test 'greater 'cond (cond ((> 3 2) 'greater)
 132                            ((< 3 2) 'less)))
 133 (test 'equal 'cond (cond ((> 3 3) 'greater)
 134                          ((< 3 3) 'less)
 135                          (else 'equal)))
 136 (test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
 137                      (else #f)))
 138 (test 'composite 'case (case (* 2 3)
 139                          ((2 3 5 7) 'prime)
 140                          ((1 4 6 8 9) 'composite)))
 141 (test 'consonant 'case (case (car '(c d))
 142                          ((a e i o u) 'vowel)
 143                          ((w y) 'semivowel)
 144                          (else 'consonant)))
 145 (test #t 'and (and (= 2 2) (> 2 1)))
 146 (test #f 'and (and (= 2 2) (< 2 1)))
 147 (test '(f g) 'and (and 1 2 'c '(f g)))
 148 (test #t 'and (and))
 149 (test #t 'or (or (= 2 2) (> 2 1)))
 150 (test #t 'or (or (= 2 2) (< 2 1)))
 151 (test #f 'or (or #f #f #f))
 152 (test #f 'or (or))
 153 (test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
 154 (SECTION 4 2 2)
 155 (test 6 'let (let ((x 2) (y 3)) (* x y)))
 156 (test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
 157 (test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
 158 (test #t 'letrec (letrec ((even?
 159                            (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
 160                           (odd?
 161                            (lambda (n) (if (zero? n) #f (even? (- n 1))))))
 162                    (even? 88)))
 163 (define x 34)
 164 (test 5 'let (let ((x 3)) (define x 5) x))
 165 (test 34 'let x)
 166 (test 6 'let (let () (define x 6) x))
 167 (test 34 'let x)
 168 (test 7 'let* (let* ((x 3)) (define x 7) x))
 169 (test 34 'let* x)
 170 (test 8 'let* (let* () (define x 8) x))
 171 (test 34 'let* x)
 172 (test 9 'letrec (letrec () (define x 9) x))
 173 (test 34 'letrec x)
 174 (test 10 'letrec (letrec ((x 3)) (define x 10) x))
 175 (test 34 'letrec x)
 176 (SECTION 4 2 3)
 177 (define x 0)
 178 (test 6 'begin (begin (set! x 5) (+ x 1)))
 179 (SECTION 4 2 4)
 180 (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
 181                             (i 0 (+ i 1)))
 182                            ((= i 5) vec)
 183                          (vector-set! vec i i)))
 184 (test 25 'do (let ((x '(1 3 5 7 9)))
 185                (do ((x x (cdr x))
 186                     (sum 0 (+ sum (car x))))
 187                    ((null? x) sum))))
 188 (test 1 'let (let foo () 1))
 189 (test '((6 1 3) (-5 -2)) 'let
 190       (let loop ((numbers '(3 -2 1 6 -5))
 191                  (nonneg '())
 192                  (neg '()))
 193         (cond ((null? numbers) (list nonneg neg))
 194               ((negative? (car numbers))
 195                (loop (cdr numbers)
 196                      nonneg
 197                      (cons (car numbers) neg)))
 198               (else
 199                (loop (cdr numbers)
 200                      (cons (car numbers) nonneg)
 201                      neg)))))
 202 (SECTION 4 2 6)
 203 (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
 204 (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
 205 (test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
 206 (test '((foo 7) . cons)
 207         'quasiquote
 208         `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
 209
 210 ;;; sqt is defined here because not all implementations are required to
 211 ;;; support it.
 212 (define (sqt x)
 213         (do ((i 0 (+ i 1)))
 214             ((> (* i i) x) (- i 1))))
 215
 216 (test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
 217 (test 5 'quasiquote `,(+ 2 3))
 218 (test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
 219       'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
 220 (test '(a `(b ,x ,'y d) e) 'quasiquote
 221         (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
 222 (test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
 223 (test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
 224 (SECTION 5 2 1)
 225 (define add3 (lambda (x) (+ x 3)))
 226 (test 6 'define (add3 3))
 227 (define first car)
 228 (test 1 'define (first '(1 2)))
 229 (SECTION 5 2 2)
 230 (test 45 'define
 231         (let ((x 5))
 232                 (define foo (lambda (y) (bar x y)))
 233                 (define bar (lambda (a b) (+ (* a b) a)))
 234                 (foo (+ x 3))))
 235 (define x 34)
 236 (define (foo) (define x 5) x)
 237 (test 5 foo)
 238 (test 34 'define x)
 239 (define foo (lambda () (define x 5) x))
 240 (test 5 foo)
 241 (test 34 'define x)
 242 (define (foo x) ((lambda () (define x 5) x)) x)
 243 (test 88 foo 88)
 244 (test 4 foo 4)
 245 (test 34 'define x)
 246 (SECTION 6 1)
 247 (test #f not #t)
 248 (test #f not 3)
 249 (test #f not (list 3))
 250 (test #t not #f)
 251 (test #f not '())
 252 (test #f not (list))
 253 (test #f not 'nil)
 254
 255 (test #t boolean? #f)
 256 (test #f boolean? 0)
 257 (test #f boolean? '())
 258 (SECTION 6 2)
 259 (test #t eqv? 'a 'a)
 260 (test #f eqv? 'a 'b)
 261 (test #t eqv? 2 2)
 262 (test #t eqv? '() '())
 263 (test #t eqv? '10000 '10000)
 264 (test #f eqv? (cons 1 2)(cons 1 2))
 265 (test #f eqv? (lambda () 1) (lambda () 2))
 266 (test #f eqv? #f 'nil)
 267 (let ((p (lambda (x) x)))
 268   (test #t eqv? p p))
 269 (define gen-counter
 270  (lambda ()
 271    (let ((n 0))
 272       (lambda () (set! n (+ n 1)) n))))
 273 (let ((g (gen-counter))) (test #t eqv? g g))
 274 (test #f eqv? (gen-counter) (gen-counter))
 275 (letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
 276          (g (lambda () (if (eqv? f g) 'g 'both))))
 277   (test #f eqv? f g))
 278
 279 (test #t eq? 'a 'a)
 280 (test #f eq? (list 'a) (list 'a))
 281 (test #t eq? '() '())
 282 (test #t eq? car car)
 283 (let ((x '(a))) (test #t eq? x x))
 284 (let ((x '#())) (test #t eq? x x))
 285 (let ((x (lambda (x) x))) (test #t eq? x x))
 286
 287 (test #t equal? 'a 'a)
 288 (test #t equal? '(a) '(a))
 289 (test #t equal? '(a (b) c) '(a (b) c))
 290 (test #t equal? "abc" "abc")
 291 (test #t equal? 2 2)
 292 (test #t equal? (make-vector 5 'a) (make-vector 5 'a))
 293 (SECTION 6 3)
 294 (test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
 295 (define x (list 'a 'b 'c))
 296 (define y x)
 297 (and list? (test #t list? y))
 298 (set-cdr! x 4)
 299 (test '(a . 4) 'set-cdr! x)
 300 (test #t eqv? x y)
 301 (test '(a b c . d) 'dot '(a . (b . (c . d))))
 302 (and list? (test #f list? y))
 303 (and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
 304
 305 (test #t pair? '(a . b))
 306 (test #t pair? '(a . 1))
 307 (test #t pair? '(a b c))
 308 (test #f pair? '())
 309 (test #f pair? '#(a b))
 310
 311 (test '(a) cons 'a '())
 312 (test '((a) b c d) cons '(a) '(b c d))
 313 (test '("a" b c) cons "a" '(b c))
 314 (test '(a . 3) cons 'a 3)
 315 (test '((a b) . c) cons '(a b) 'c)
 316
 317 (test 'a car '(a b c))
 318 (test '(a) car '((a) b c d))
 319 (test 1 car '(1 . 2))
 320
 321 (test '(b c d) cdr '((a) b c d))
 322 (test 2 cdr '(1 . 2))
 323
 324 (test '(a 7 c) list 'a (+ 3 4) 'c)
 325 (test '() list)
 326
 327 (test 3 length '(a b c))
 328 (test 3 length '(a (b) (c d e)))
 329 (test 0 length '())
 330
 331 (test '(x y) append '(x) '(y))
 332 (test '(a b c d) append '(a) '(b c d))
 333 (test '(a (b) (c)) append '(a (b)) '((c)))
 334 (test '() append)
 335 (test '(a b c . d) append '(a b) '(c . d))
 336 (test 'a append '() 'a)
 337
 338 (test '(c b a) reverse '(a b c))
 339 (test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
 340
 341 (test 'c list-ref '(a b c d) 2)
 342
 343 (test '(a b c) memq 'a '(a b c))
 344 (test '(b c) memq 'b '(a b c))
 345 (test '#f memq 'a '(b c d))
 346 (test '#f memq (list 'a) '(b (a) c))
 347 (test '((a) c) member (list 'a) '(b (a) c))
 348 (test '(101 102) memv 101 '(100 101 102))
 349
 350 (define e '((a 1) (b 2) (c 3)))
 351 (test '(a 1) assq 'a e)
 352 (test '(b 2) assq 'b e)
 353 (test #f assq 'd e)
 354 (test #f assq (list 'a) '(((a)) ((b)) ((c))))
 355 (test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
 356 (test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
 357 (SECTION 6 4)
 358 (test #t symbol? 'foo)
 359 (test #t symbol? (car '(a b)))
 360 (test #f symbol? "bar")
 361 (test #t symbol? 'nil)
 362 (test #f symbol? '())
 363 (test #f symbol? #f)
 364 ;;; But first, what case are symbols in?  Determine the standard case:
 365 (define char-standard-case char-upcase)
 366 (if (string=? (symbol->string 'A) "a")
 367     (set! char-standard-case char-downcase))
 368 ;;; Not for Guile
 369 ;(test #t 'standard-case
 370 ;      (string=? (symbol->string 'a) (symbol->string 'A)))
 371 ;(test #t 'standard-case
 372 ;      (or (string=? (symbol->string 'a) "A")
 373 ;         (string=? (symbol->string 'A) "a")))
 374 (define (str-copy s)
 375   (let ((v (make-string (string-length s))))
 376     (do ((i (- (string-length v) 1) (- i 1)))
 377         ((< i 0) v)
 378       (string-set! v i (string-ref s i)))))
 379 (define (string-standard-case s)
 380   (set! s (str-copy s))
 381   (do ((i 0 (+ 1 i))
 382        (sl (string-length s)))
 383       ((>= i sl) s)
 384       (string-set! s i (char-standard-case (string-ref s i)))))
 385 ;;; Not for Guile
 386 ;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
 387 ;(test (string-standard-case "martin") symbol->string 'Martin)
 388 (test "Malvina" symbol->string (string->symbol "Malvina"))
 389 ;;; Not for Guile
 390 ;(test #t 'standard-case (eq? 'a 'A))
 391
 392 (define x (string #\a #\b))
 393 (define y (string->symbol x))
 394 (string-set! x 0 #\c)
 395 (test "cb" 'string-set! x)
 396 (test "ab" symbol->string y)
 397 (test y string->symbol "ab")
 398
 399 ;;; Not for Guile
 400 ;(test #t eq? 'mISSISSIppi 'mississippi)
 401 ;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
 402 (test 'JollyWog string->symbol (symbol->string 'JollyWog))
 403
 404 (SECTION 6 5 5)
 405 (test #t number? 3)
 406 (test #t complex? 3)
 407 (test #t real? 3)
 408 (test #t rational? 3)
 409 (test #t integer? 3)
 410
 411 (test #t exact? 3)
 412 (test #f inexact? 3)
 413
 414 (test #t = 22 22 22)
 415 (test #t = 22 22)
 416 (test #f = 34 34 35)
 417 (test #f = 34 35)
 418 (test #t > 3 -6246)
 419 (test #f > 9 9 -2424)
 420 (test #t >= 3 -4 -6246)
 421 (test #t >= 9 9)
 422 (test #f >= 8 9)
 423 (test #t < -1 2 3 4 5 6 7 8)
 424 (test #f < -1 2 3 4 4 5 6 7)
 425 (test #t <= -1 2 3 4 5 6 7 8)
 426 (test #t <= -1 2 3 4 4 5 6 7)
 427 (test #f < 1 3 2)
 428 (test #f >= 1 3 2)
 429
 430 (test #t zero? 0)
 431 (test #f zero? 1)
 432 (test #f zero? -1)
 433 (test #f zero? -100)
 434 (test #t positive? 4)
 435 (test #f positive? -4)
 436 (test #f positive? 0)
 437 (test #f negative? 4)
 438 (test #t negative? -4)
 439 (test #f negative? 0)
 440 (test #t odd? 3)
 441 (test #f odd? 2)
 442 (test #f odd? -4)
 443 (test #t odd? -1)
 444 (test #f even? 3)
 445 (test #t even? 2)
 446 (test #t even? -4)
 447 (test #f even? -1)
 448
 449 (test 38 max 34 5 7 38 6)
 450 (test -24 min 3  5 5 330 4 -24)
 451
 452 (test 7 + 3 4)
 453 (test '3 + 3)
 454 (test 0 +)
 455 (test 4 * 4)
 456 (test 1 *)
 457
 458 (test -1 - 3 4)
 459 (test -3 - 3)
 460 (test 7 abs -7)
 461 (test 7 abs 7)
 462 (test 0 abs 0)
 463
 464 (test 5 quotient 35 7)
 465 (test -5 quotient -35 7)
 466 (test -5 quotient 35 -7)
 467 (test 5 quotient -35 -7)
 468 (test 1 modulo 13 4)
 469 (test 1 remainder 13 4)
 470 (test 3 modulo -13 4)
 471 (test -1 remainder -13 4)
 472 (test -3 modulo 13 -4)
 473 (test 1 remainder 13 -4)
 474 (test -1 modulo -13 -4)
 475 (test -1 remainder -13 -4)
 476 (define (divtest n1 n2)
 477         (= n1 (+ (* n2 (quotient n1 n2))
 478                  (remainder n1 n2))))
 479 (test #t divtest 238 9)
 480 (test #t divtest -238 9)
 481 (test #t divtest 238 -9)
 482 (test #t divtest -238 -9)
 483
 484 (test 4 gcd 0 4)
 485 (test 4 gcd -4 0)
 486 (test 4 gcd 32 -36)
 487 (test 0 gcd)
 488 (test 288 lcm 32 -36)
 489 (test 1 lcm)
 490
 491 ;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
 492 ;;; Modified by jaffer.
 493 (define (test-inexact)
 494   (define f3.9 (string->number "3.9"))
 495   (define f4.0 (string->number "4.0"))
 496   (define f-3.25 (string->number "-3.25"))
 497   (define f.25 (string->number ".25"))
 498   (define f4.5 (string->number "4.5"))
 499   (define f3.5 (string->number "3.5"))
 500   (define f0.0 (string->number "0.0"))
 501   (define f0.8 (string->number "0.8"))
 502   (define f1.0 (string->number "1.0"))
 503   (define wto write-test-obj)
 504   (define dto display-test-obj)
 505   (define lto load-test-obj)
 506   (newline)
 507   (display ";testing inexact numbers; ")
 508   (newline)
 509   (SECTION 6 5 5)
 510   (test #t inexact? f3.9)
 511   (test #t 'inexact? (inexact? (max f3.9 4)))
 512   (test f4.0 'max (max f3.9 4))
 513   (test f4.0 'exact->inexact (exact->inexact 4))
 514   (test (- f4.0) round (- f4.5))
 515   (test (- f4.0) round (- f3.5))
 516   (test (- f4.0) round (- f3.9))
 517   (test f0.0 round f0.0)
 518   (test f0.0 round f.25)
 519   (test f1.0 round f0.8)
 520   (test f4.0 round f3.5)
 521   (test f4.0 round f4.5)
 522   (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
 523   (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
 524   (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
 525   (test #t call-with-output-file
 526       "tmp3"
 527       (lambda (test-file)
 528         (write-char #\; test-file)
 529         (display write-test-obj test-file)
 530         (newline test-file)
 531         (write load-test-obj test-file)
 532         (output-port? test-file)))
 533   (check-test-file "tmp3")
 534   (set! write-test-obj wto)
 535   (set! display-test-obj dto)
 536   (set! load-test-obj lto)
 537   (let ((x (string->number "4195835.0"))
 538         (y (string->number "3145727.0")))
 539     (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
 540   (report-errs))
 541
 542 (define (test-bignum)
 543   (define tb
 544     (lambda (n1 n2)
 545       (= n1 (+ (* n2 (quotient n1 n2))
 546                (remainder n1 n2)))))
 547   (newline)
 548   (display ";testing bignums; ")
 549   (newline)
 550   (SECTION 6 5 5)
 551   (test 0 modulo -2177452800 86400)
 552   (test 0 modulo 2177452800 -86400)
 553   (test 0 modulo 2177452800 86400)
 554   (test 0 modulo -2177452800 -86400)
 555   (test #t 'remainder (tb 281474976710655 65535))
 556   (test #t 'remainder (tb 281474976710654 65535))
 557   (SECTION 6 5 6)
 558   (test 281474976710655 string->number "281474976710655")
 559   (test "281474976710655" number->string 281474976710655)
 560   (report-errs))
 561
 562 (SECTION 6 5 6)
 563 (test "0" number->string 0)
 564 (test "100" number->string 100)
 565 (test "100" number->string 256 16)
 566 (test 100 string->number "100")
 567 (test 256 string->number "100" 16)
 568 (test #f string->number "")
 569 (test #f string->number ".")
 570 (test #f string->number "d")
 571 (test #f string->number "D")
 572 (test #f string->number "i")
 573 (test #f string->number "I")
 574 (test #f string->number "3i")
 575 (test #f string->number "3I")
 576 (test #f string->number "33i")
 577 (test #f string->number "33I")
 578 (test #f string->number "3.3i")
 579 (test #f string->number "3.3I")
 580 (test #f string->number "-")
 581 (test #f string->number "+")
 582
 583 (SECTION 6 6)
 584 (test #t eqv? '#\  #\Space)
 585 (test #t eqv? #\space '#\Space)
 586 (test #t char? #\a)
 587 (test #t char? #\()
 588 (test #t char? #\ )
 589 (test #t char? '#\newline)
 590
 591 (test #f char=? #\A #\B)
 592 (test #f char=? #\a #\b)
 593 (test #f char=? #\9 #\0)
 594 (test #t char=? #\A #\A)
 595
 596 (test #t char<? #\A #\B)
 597 (test #t char<? #\a #\b)
 598 (test #f char<? #\9 #\0)
 599 (test #f char<? #\A #\A)
 600
 601 (test #f char>? #\A #\B)
 602 (test #f char>? #\a #\b)
 603 (test #t char>? #\9 #\0)
 604 (test #f char>? #\A #\A)
 605
 606 (test #t char<=? #\A #\B)
 607 (test #t char<=? #\a #\b)
 608 (test #f char<=? #\9 #\0)
 609 (test #t char<=? #\A #\A)
 610
 611 (test #f char>=? #\A #\B)
 612 (test #f char>=? #\a #\b)
 613 (test #t char>=? #\9 #\0)
 614 (test #t char>=? #\A #\A)
 615
 616 (test #f char-ci=? #\A #\B)
 617 (test #f char-ci=? #\a #\B)
 618 (test #f char-ci=? #\A #\b)
 619 (test #f char-ci=? #\a #\b)
 620 (test #f char-ci=? #\9 #\0)
 621 (test #t char-ci=? #\A #\A)
 622 (test #t char-ci=? #\A #\a)
 623
 624 (test #t char-ci<? #\A #\B)
 625 (test #t char-ci<? #\a #\B)
 626 (test #t char-ci<? #\A #\b)
 627 (test #t char-ci<? #\a #\b)
 628 (test #f char-ci<? #\9 #\0)
 629 (test #f char-ci<? #\A #\A)
 630 (test #f char-ci<? #\A #\a)
 631
 632 (test #f char-ci>? #\A #\B)
 633 (test #f char-ci>? #\a #\B)
 634 (test #f char-ci>? #\A #\b)
 635 (test #f char-ci>? #\a #\b)
 636 (test #t char-ci>? #\9 #\0)
 637 (test #f char-ci>? #\A #\A)
 638 (test #f char-ci>? #\A #\a)
 639
 640 (test #t char-ci<=? #\A #\B)
 641 (test #t char-ci<=? #\a #\B)
 642 (test #t char-ci<=? #\A #\b)
 643 (test #t char-ci<=? #\a #\b)
 644 (test #f char-ci<=? #\9 #\0)
 645 (test #t char-ci<=? #\A #\A)
 646 (test #t char-ci<=? #\A #\a)
 647
 648 (test #f char-ci>=? #\A #\B)
 649 (test #f char-ci>=? #\a #\B)
 650 (test #f char-ci>=? #\A #\b)
 651 (test #f char-ci>=? #\a #\b)
 652 (test #t char-ci>=? #\9 #\0)
 653 (test #t char-ci>=? #\A #\A)
 654 (test #t char-ci>=? #\A #\a)
 655
 656 (test #t char-alphabetic? #\a)
 657 (test #t char-alphabetic? #\A)
 658 (test #t char-alphabetic? #\z)
 659 (test #t char-alphabetic? #\Z)
 660 (test #f char-alphabetic? #\0)
 661 (test #f char-alphabetic? #\9)
 662 (test #f char-alphabetic? #\space)
 663 (test #f char-alphabetic? #\;)
 664
 665 (test #f char-numeric? #\a)
 666 (test #f char-numeric? #\A)
 667 (test #f char-numeric? #\z)
 668 (test #f char-numeric? #\Z)
 669 (test #t char-numeric? #\0)
 670 (test #t char-numeric? #\9)
 671 (test #f char-numeric? #\space)
 672 (test #f char-numeric? #\;)
 673
 674 (test #f char-whitespace? #\a)
 675 (test #f char-whitespace? #\A)
 676 (test #f char-whitespace? #\z)
 677 (test #f char-whitespace? #\Z)
 678 (test #f char-whitespace? #\0)
 679 (test #f char-whitespace? #\9)
 680 (test #t char-whitespace? #\space)
 681 (test #f char-whitespace? #\;)
 682
 683 (test #f char-upper-case? #\0)
 684 (test #f char-upper-case? #\9)
 685 (test #f char-upper-case? #\space)
 686 (test #f char-upper-case? #\;)
 687
 688 (test #f char-lower-case? #\0)
 689 (test #f char-lower-case? #\9)
 690 (test #f char-lower-case? #\space)
 691 (test #f char-lower-case? #\;)
 692
 693 (test #\. integer->char (char->integer #\.))
 694 (test #\A integer->char (char->integer #\A))
 695 (test #\a integer->char (char->integer #\a))
 696 (test #\A char-upcase #\A)
 697 (test #\A char-upcase #\a)
 698 (test #\a char-downcase #\A)
 699 (test #\a char-downcase #\a)
 700 (SECTION 6 7)
 701 (test #t string? "The word \"recursion\\\" has many meanings.")
 702 (test #t string? "")
 703 (define f (make-string 3 #\*))
 704 (test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
 705 (test "abc" string #\a #\b #\c)
 706 (test "" string)
 707 (test 3 string-length "abc")
 708 (test #\a string-ref "abc" 0)
 709 (test #\c string-ref "abc" 2)
 710 (test 0 string-length "")
 711 (test "" substring "ab" 0 0)
 712 (test "" substring "ab" 1 1)
 713 (test "" substring "ab" 2 2)
 714 (test "a" substring "ab" 0 1)
 715 (test "b" substring "ab" 1 2)
 716 (test "ab" substring "ab" 0 2)
 717 (test "foobar" string-append "foo" "bar")
 718 (test "foo" string-append "foo")
 719 (test "foo" string-append "foo" "")
 720 (test "foo" string-append "" "foo")
 721 (test "" string-append)
 722 (test "" make-string 0)
 723 (test #t string=? "" "")
 724 (test #f string<? "" "")
 725 (test #f string>? "" "")
 726 (test #t string<=? "" "")
 727 (test #t string>=? "" "")
 728 (test #t string-ci=? "" "")
 729 (test #f string-ci<? "" "")
 730 (test #f string-ci>? "" "")
 731 (test #t string-ci<=? "" "")
 732 (test #t string-ci>=? "" "")
 733
 734 (test #f string=? "A" "B")
 735 (test #f string=? "a" "b")
 736 (test #f string=? "9" "0")
 737 (test #t string=? "A" "A")
 738
 739 (test #t string<? "A" "B")
 740 (test #t string<? "a" "b")
 741 (test #f string<? "9" "0")
 742 (test #f string<? "A" "A")
 743
 744 (test #f string>? "A" "B")
 745 (test #f string>? "a" "b")
 746 (test #t string>? "9" "0")
 747 (test #f string>? "A" "A")
 748
 749 (test #t string<=? "A" "B")
 750 (test #t string<=? "a" "b")
 751 (test #f string<=? "9" "0")
 752 (test #t string<=? "A" "A")
 753
 754 (test #f string>=? "A" "B")
 755 (test #f string>=? "a" "b")
 756 (test #t string>=? "9" "0")
 757 (test #t string>=? "A" "A")
 758
 759 (test #f string-ci=? "A" "B")
 760 (test #f string-ci=? "a" "B")
 761 (test #f string-ci=? "A" "b")
 762 (test #f string-ci=? "a" "b")
 763 (test #f string-ci=? "9" "0")
 764 (test #t string-ci=? "A" "A")
 765 (test #t string-ci=? "A" "a")
 766
 767 (test #t string-ci<? "A" "B")
 768 (test #t string-ci<? "a" "B")
 769 (test #t string-ci<? "A" "b")
 770 (test #t string-ci<? "a" "b")
 771 (test #f string-ci<? "9" "0")
 772 (test #f string-ci<? "A" "A")
 773 (test #f string-ci<? "A" "a")
 774
 775 (test #f string-ci>? "A" "B")
 776 (test #f string-ci>? "a" "B")
 777 (test #f string-ci>? "A" "b")
 778 (test #f string-ci>? "a" "b")
 779 (test #t string-ci>? "9" "0")
 780 (test #f string-ci>? "A" "A")
 781 (test #f string-ci>? "A" "a")
 782
 783 (test #t string-ci<=? "A" "B")
 784 (test #t string-ci<=? "a" "B")
 785 (test #t string-ci<=? "A" "b")
 786 (test #t string-ci<=? "a" "b")
 787 (test #f string-ci<=? "9" "0")
 788 (test #t string-ci<=? "A" "A")
 789 (test #t string-ci<=? "A" "a")
 790
 791 (test #f string-ci>=? "A" "B")
 792 (test #f string-ci>=? "a" "B")
 793 (test #f string-ci>=? "A" "b")
 794 (test #f string-ci>=? "a" "b")
 795 (test #t string-ci>=? "9" "0")
 796 (test #t string-ci>=? "A" "A")
 797 (test #t string-ci>=? "A" "a")
 798 (SECTION 6 8)
 799 (test #t vector? '#(0 (2 2 2 2) "Anna"))
 800 (test #t vector? '#())
 801 (test '#(a b c) vector 'a 'b 'c)
 802 (test '#() vector)
 803 (test 3 vector-length '#(0 (2 2 2 2) "Anna"))
 804 (test 0 vector-length '#())
 805 (test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
 806 (test '#(0 ("Sue" "Sue") "Anna") 'vector-set
 807         (let ((vec (vector 0 '(2 2 2 2) "Anna")))
 808           (vector-set! vec 1 '("Sue" "Sue"))
 809           vec))
 810 (test '#(hi hi) make-vector 2 'hi)
 811 (test '#() make-vector 0)
 812 (test '#() make-vector 0 'a)
 813 (SECTION 6 9)
 814 (test #t procedure? car)
 815 (test #f procedure? 'car)
 816 (test #t procedure? (lambda (x) (* x x)))
 817 (test #f procedure? '(lambda (x) (* x x)))
 818 (test #t call-with-current-continuation procedure?)
 819 (test 7 apply + (list 3 4))
 820 (test 7 apply (lambda (a b) (+ a b)) (list 3 4))
 821 (test 17 apply + 10 (list 3 4))
 822 (test '() apply list '())
 823 (define compose (lambda (f g) (lambda args (f (apply g args)))))
 824 (test 30 (compose sqt *) 12 75)
 825
 826 (test '(b e h) map cadr '((a b) (d e) (g h)))
 827 (test '(5 7 9) map + '(1 2 3) '(4 5 6))
 828 (test '#(0 1 4 9 16) 'for-each
 829         (let ((v (make-vector 5)))
 830                 (for-each (lambda (i) (vector-set! v i (* i i)))
 831                         '(0 1 2 3 4))
 832                 v))
 833 (test -3 call-with-current-continuation
 834                 (lambda (exit)
 835                  (for-each (lambda (x) (if (negative? x) (exit x)))
 836                         '(54 0 37 -3 245 19))
 837                 #t))
 838 (define list-length
 839  (lambda (obj)
 840   (call-with-current-continuation
 841    (lambda (return)
 842     (letrec ((r (lambda (obj) (cond ((null? obj) 0)
 843                                 ((pair? obj) (+ (r (cdr obj)) 1))
 844                                 (else (return #f))))))
 845         (r obj))))))
 846 (test 4 list-length '(1 2 3 4))
 847 (test #f list-length '(a b . c))
 848 (test '() map cadr '())
 849
 850 ;;; This tests full conformance of call-with-current-continuation.  It
 851 ;;; is a separate test because some schemes do not support call/cc
 852 ;;; other than escape procedures.  I am indebted to
 853 ;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
 854 ;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
 855 ;;; trees constructed of conses.
 856 (define (next-leaf-generator obj eot)
 857   (letrec ((return #f)
 858            (cont (lambda (x)
 859                    (recur obj)
 860                    (set! cont (lambda (x) (return eot)))
 861                    (cont #f)))
 862            (recur (lambda (obj)
 863                       (if (pair? obj)
 864                           (for-each recur obj)
 865                           (call-with-current-continuation
 866                            (lambda (c)
 867                              (set! cont c)
 868                              (return obj)))))))
 869     (lambda () (call-with-current-continuation
 870                 (lambda (ret) (set! return ret) (cont #f))))))
 871 (define (leaf-eq? x y)
 872   (let* ((eot (list 'eot))
 873          (xf (next-leaf-generator x eot))
 874          (yf (next-leaf-generator y eot)))
 875     (letrec ((loop (lambda (x y)
 876                      (cond ((not (eq? x y)) #f)
 877                            ((eq? eot x) #t)
 878                            (else (loop (xf) (yf)))))))
 879       (loop (xf) (yf)))))
 880 (define (test-cont)
 881   (newline)
 882   (display ";testing continuations; ")
 883   (newline)
 884   (SECTION 6 9)
 885   (test #t leaf-eq? '(a (b (c))) '((a) b c))
 886   (test #f leaf-eq? '(a (b (c))) '((a) b c d))
 887   (report-errs))
 888
 889 ;;; Test Optional R4RS DELAY syntax and FORCE procedure
 890 (define (test-delay)
 891   (newline)
 892   (display ";testing DELAY and FORCE; ")
 893   (newline)
 894   (SECTION 6 9)
 895   (test 3 'delay (force (delay (+ 1 2))))
 896   (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
 897                         (list (force p) (force p))))
 898   (test 2 'delay (letrec ((a-stream
 899                            (letrec ((next (lambda (n)
 900                                             (cons n (delay (next (+ n 1)))))))
 901                              (next 0)))
 902                           (head car)
 903                           (tail (lambda (stream) (force (cdr stream)))))
 904                    (head (tail (tail a-stream)))))
 905   (letrec ((count 0)
 906            (p (delay (begin (set! count (+ count 1))
 907                             (if (> count x)
 908                                 count
 909                                 (force p)))))
 910            (x 5))
 911     (test 6 force p)
 912     (set! x 10)
 913     (test 6 force p))
 914   (test 3 'force
 915         (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
 916                  (c #f))
 917           (force p)))
 918   (report-errs))
 919
 920 (SECTION 6 10 1)
 921 (test #t input-port? (current-input-port))
 922 (test #t output-port? (current-output-port))
 923 (test #t call-with-input-file "test.scm" input-port?)
 924 (define this-file (open-input-file "test.scm"))
 925 (test #t input-port? this-file)
 926 (SECTION 6 10 2)
 927 (test #\; peek-char this-file)
 928 (test #\; read-char this-file)
 929 (test '(define cur-section '()) read this-file)
 930 (test #\( peek-char this-file)
 931 (test '(define errs '()) read this-file)
 932 (close-input-port this-file)
 933 (close-input-port this-file)
 934 (define (check-test-file name)
 935   (define test-file (open-input-file name))
 936   (test #t 'input-port?
 937         (call-with-input-file
 938             name
 939           (lambda (test-file)
 940             (test load-test-obj read test-file)
 941             (test #t eof-object? (peek-char test-file))
 942             (test #t eof-object? (read-char test-file))
 943             (input-port? test-file))))
 944   (test #\; read-char test-file)
 945   (test display-test-obj read test-file)
 946   (test load-test-obj read test-file)
 947   (close-input-port test-file))
 948 (SECTION 6 10 3)
 949 (define write-test-obj
 950   '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
 951 (define display-test-obj
 952   '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
 953 (define load-test-obj
 954   (list 'define 'foo (list 'quote write-test-obj)))
 955 (test #t call-with-output-file
 956       "tmp1"
 957       (lambda (test-file)
 958         (write-char #\; test-file)
 959         (display write-test-obj test-file)
 960         (newline test-file)
 961         (write load-test-obj test-file)
 962         (output-port? test-file)))
 963 (check-test-file "tmp1")
 964
 965 (define test-file (open-output-file "tmp2"))
 966 (write-char #\; test-file)
 967 (display write-test-obj test-file)
 968 (newline test-file)
 969 (write load-test-obj test-file)
 970 (test #t output-port? test-file)
 971 (close-output-port test-file)
 972 (check-test-file "tmp2")
 973 (define (test-sc4)
 974   (newline)
 975   (display ";testing scheme 4 functions; ")
 976   (newline)
 977   (SECTION 6 7)
 978   (test '(#\P #\space #\l) string->list "P l")
 979   (test '() string->list "")
 980   (test "1\\\"" list->string '(#\1 #\\ #\"))
 981   (test "" list->string '())
 982   (SECTION 6 8)
 983   (test '(dah dah didah) vector->list '#(dah dah didah))
 984   (test '() vector->list '#())
 985   (test '#(dididit dah) list->vector '(dididit dah))
 986   (test '#() list->vector '())
 987   (SECTION 6 10 4)
 988   (load "tmp1")
 989   (test write-test-obj 'load foo)
 990   (report-errs))
 991
 992 (report-errs)
 993 (if (and (string->number "0.0") (inexact? (string->number "0.0")))
 994     (test-inexact))
 995
 996 (let ((n (string->number "281474976710655")))
 997   (if (and n (exact? n))
 998       (test-bignum)))
 999 (newline)
1000 (test-cont)
1001 (newline)
1002 (test-sc4)
1003 (newline)
1004 (test-delay)
1005 (newline)
1006 "last item in file"