tests/r4rstest.scm

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