~ chicken-core (chicken-5) /tests/r4rstest.scm

   1;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003 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'.out, `tmp2.out' and `tmp3.out' will be created in the course
  28;;; of running 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 agj @ alum.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(define (s x) (if x (let () (set! s x) (set! x s))))
 188(SECTION 4 2 3)
 189(define x 0)
 190(test 6 'begin (begin (set! x (begin (begin 5)))
 191		      (begin ((begin +) (begin x) (begin (begin 1))))))
 192(SECTION 4 2 4)
 193(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
 194			    (i 0 (+ i 1)))
 195			   ((= i 5) vec)
 196			 (vector-set! vec i i)))
 197(test 25 'do (let ((x '(1 3 5 7 9)))
 198	       (do ((x x (cdr x))
 199		    (sum 0 (+ sum (car x))))
 200		   ((null? x) sum))))
 201(test 1 'let (let foo () 1))
 202(test '((6 1 3) (-5 -2)) 'let
 203      (let loop ((numbers '(3 -2 1 6 -5))
 204		 (nonneg '())
 205		 (neg '()))
 206	(cond ((null? numbers) (list nonneg neg))
 207	      ((negative? (car numbers))
 208	       (loop (cdr numbers)
 209		     nonneg
 210		     (cons (car numbers) neg)))
 211	      (else
 212	       (loop (cdr numbers)
 213		     (cons (car numbers) nonneg)
 214		     neg)))))
 215;;From: Allegro Petrofsky <Allegro@Petrofsky.Berkeley.CA.US>
 216(test -1 'let (let ((f -)) (let f ((n (f 1))) n)))
 217
 218(SECTION 4 2 6)
 219(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
 220(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
 221(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
 222(test '((foo 7) . cons)
 223	'quasiquote
 224	`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
 225
 226;;; sqt is defined here because not all implementations are required to
 227;;; support it.
 228(define (sqt x)
 229	(do ((i 0 (+ i 1)))
 230	    ((> (* i i) x) (- i 1))))
 231
 232(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
 233(test 5 'quasiquote `,(+ 2 3))
 234(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
 235      'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
 236(test '(a `(b ,x ,'y d) e) 'quasiquote
 237	(let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
 238(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
 239(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
 240(SECTION 5 2 1)
 241(define add3 (lambda (x) (+ x 3)))
 242(test 6 'define (add3 3))
 243(define first car)
 244(test 1 'define (first '(1 2)))
 245(define old-+ +)
 246(begin (begin (begin)
 247	      (begin (begin (begin) (define + (lambda (x y) (list y x)))
 248			    (begin)))
 249	      (begin))
 250       (begin)
 251       (begin (begin (begin) (test '(3 6) add3 6)
 252		     (begin))))
 253(set! + old-+)
 254(test 9 add3 6)
 255(begin)
 256(begin (begin))
 257(begin (begin (begin (begin))))
 258(SECTION 5 2 2)
 259#;(test 45 'define
 260      (let ((x 5))
 261	(begin (begin (begin)
 262		      (begin (begin (begin) (define foo (lambda (y) (bar x y)))
 263				    (begin)))
 264		      (begin))
 265	       (begin)
 266	       (begin)
 267	       (begin (define bar (lambda (a b) (+ (* a b) a))))
 268	       (begin))
 269	(begin)
 270	(begin (foo (+ x 3)))))
 271(define x 34)
 272(define (foo) (define x 5) x)
 273(test 5 foo)
 274(test 34 'define x)
 275(define foo (lambda () (define x 5) x))
 276(test 5 foo)
 277(test 34 'define x)
 278(define (foo x) ((lambda () (define x 5) x)) x)
 279(test 88 foo 88)
 280(test 4 foo 4)
 281(test 34 'define x)
 282(test 99 'internal-define (letrec ((foo (lambda (arg)
 283					  (or arg (and (procedure? foo)
 284						       (foo 99))))))
 285			    (define bar (foo #f))
 286			    (foo #f)))
 287(test 77 'internal-define (letrec ((foo 77)
 288				   (bar #f)
 289				   (retfoo (lambda () foo)))
 290			    (define baz (retfoo))
 291			    (retfoo)))
 292(SECTION 6 1)
 293(test #f not #t)
 294(test #f not 3)
 295(test #f not (list 3))
 296(test #t not #f)
 297(test #f not '())
 298(test #f not (list))
 299(test #f not 'nil)
 300
 301;(test #t boolean? #f)
 302;(test #f boolean? 0)
 303;(test #f boolean? '())
 304(SECTION 6 2)
 305(test #t eqv? 'a 'a)
 306(test #f eqv? 'a 'b)
 307(test #t eqv? 2 2)
 308(test #t eqv? '() '())
 309(test #t eqv? '10000 '10000)
 310(test #f eqv? (cons 1 2)(cons 1 2))
 311(test #f eqv? (lambda () 1) (lambda () 2))
 312(test #f eqv? #f 'nil)
 313(let ((p (lambda (x) x)))
 314  (test #t eqv? p p))
 315(define gen-counter
 316 (lambda ()
 317   (let ((n 0))
 318      (lambda () (set! n (+ n 1)) n))))
 319(let ((g (gen-counter))) (test #t eqv? g g))
 320(test #f eqv? (gen-counter) (gen-counter))
 321(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
 322	 (g (lambda () (if (eqv? f g) 'g 'both))))
 323  (test #f eqv? f g))
 324
 325(test #t eq? 'a 'a)
 326(test #f eq? (list 'a) (list 'a))
 327(test #t eq? '() '())
 328(test #t eq? car car)
 329(let ((x '(a))) (test #t eq? x x))
 330(let ((x '#())) (test #t eq? x x))
 331(let ((x (lambda (x) x))) (test #t eq? x x))
 332
 333(define test-eq?-eqv?-agreement
 334  (lambda (obj1 obj2)
 335    (cond ((eq? (eq? obj1 obj2) (eqv? obj1 obj2)))
 336	  (else
 337	   (record-error (list #f #t (list 'test-eq?-eqv?-agreement obj1 obj2)))
 338	   (display "eqv? and eq? disagree about ")
 339	   (write obj1)
 340	   (display #\ )
 341	   (write obj2)
 342	   (newline)))))
 343
 344(test-eq?-eqv?-agreement '#f '#f)
 345(test-eq?-eqv?-agreement '#t '#t)
 346(test-eq?-eqv?-agreement '#t '#f)
 347(test-eq?-eqv?-agreement '(a) '(a))
 348(test-eq?-eqv?-agreement '(a) '(b))
 349(test-eq?-eqv?-agreement car car)
 350(test-eq?-eqv?-agreement car cdr)
 351(test-eq?-eqv?-agreement (list 'a) (list 'a))
 352(test-eq?-eqv?-agreement (list 'a) (list 'b))
 353(test-eq?-eqv?-agreement '#(a) '#(a))
 354(test-eq?-eqv?-agreement '#(a) '#(b))
 355(test-eq?-eqv?-agreement "abc" "abc")
 356(test-eq?-eqv?-agreement "abc" "abz")
 357
 358(test #t equal? 'a 'a)
 359(test #t equal? '(a) '(a))
 360(test #t equal? '(a (b) c) '(a (b) c))
 361(test #t equal? "abc" "abc")
 362(test #t equal? 2 2)
 363(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
 364(SECTION 6 3)
 365(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
 366(define x (list 'a 'b 'c))
 367(define y x)
 368(and list? (test #t list? y))
 369(set-cdr! x 4)
 370(test '(a . 4) 'set-cdr! x)
 371(test #t eqv? x y)
 372(test '(a b c . d) 'dot '(a . (b . (c . d))))
 373(and list? (test #f list? y))
 374(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
 375
 376;(test #t pair? '(a . b))
 377;(test #t pair? '(a . 1))
 378;(test #t pair? '(a b c))
 379;(test #f pair? '())
 380;(test #f pair? '#(a b))
 381
 382(test '(a) cons 'a '())
 383(test '((a) b c d) cons '(a) '(b c d))
 384(test '("a" b c) cons "a" '(b c))
 385(test '(a . 3) cons 'a 3)
 386(test '((a b) . c) cons '(a b) 'c)
 387
 388(test 'a car '(a b c))
 389(test '(a) car '((a) b c d))
 390(test 1 car '(1 . 2))
 391
 392(test '(b c d) cdr '((a) b c d))
 393(test 2 cdr '(1 . 2))
 394
 395(test '(a 7 c) list 'a (+ 3 4) 'c)
 396(test '() list)
 397
 398(test 3 length '(a b c))
 399(test 3 length '(a (b) (c d e)))
 400(test 0 length '())
 401
 402(test '(x y) append '(x) '(y))
 403(test '(a b c d) append '(a) '(b c d))
 404(test '(a (b) (c)) append '(a (b)) '((c)))
 405(test '() append)
 406(test '(a b c . d) append '(a b) '(c . d))
 407(test 'a append '() 'a)
 408
 409(test '(c b a) reverse '(a b c))
 410(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
 411
 412(test 'c list-ref '(a b c d) 2)
 413
 414(test '(a b c) memq 'a '(a b c))
 415(test '(b c) memq 'b '(a b c))
 416(test '#f memq 'a '(b c d))
 417(test '#f memq (list 'a) '(b (a) c))
 418(test '((a) c) member (list 'a) '(b (a) c))
 419(test '(101 102) memv 101 '(100 101 102))
 420
 421(define e '((a 1) (b 2) (c 3)))
 422(test '(a 1) assq 'a e)
 423(test '(b 2) assq 'b e)
 424(test #f assq 'd e)
 425(test #f assq (list 'a) '(((a)) ((b)) ((c))))
 426(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
 427(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
 428(SECTION 6 4)
 429;(test #t symbol? 'foo)
 430(test #t symbol? (car '(a b)))
 431;(test #f symbol? "bar")
 432;(test #t symbol? 'nil)
 433;(test #f symbol? '())
 434;(test #f symbol? #f)
 435;;; But first, what case are symbols in?  Determine the standard case:
 436(define char-standard-case char-upcase)
 437(if (string=? (symbol->string 'A) "a")
 438    (set! char-standard-case char-downcase))
 439(test #t 'standard-case
 440      (string=? (symbol->string 'a) (symbol->string 'A)))
 441(test #t 'standard-case
 442      (or (string=? (symbol->string 'a) "A")
 443	  (string=? (symbol->string 'A) "a")))
 444(define (str-copy s)
 445  (let ((v (make-string (string-length s))))
 446    (do ((i (- (string-length v) 1) (- i 1)))
 447	((< i 0) v)
 448      (string-set! v i (string-ref s i)))))
 449(define (string-standard-case s)
 450  (set! s (str-copy s))
 451  (do ((i 0 (+ 1 i))
 452       (sl (string-length s)))
 453      ((>= i sl) s)
 454      (string-set! s i (char-standard-case (string-ref s i)))))
 455(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
 456(test (string-standard-case "martin") symbol->string 'Martin)
 457(test "Malvina" symbol->string (string->symbol "Malvina"))
 458(test #t 'standard-case (eq? 'a 'A))
 459
 460(define x (string #\a #\b))
 461(define y (string->symbol x))
 462(string-set! x 0 #\c)
 463(test "cb" 'string-set! x)
 464(test "ab" symbol->string y)
 465(test y string->symbol "ab")
 466
 467(test #t eq? 'mISSISSIppi 'mississippi)
 468(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
 469(test 'JollyWog string->symbol (symbol->string 'JollyWog))
 470
 471(SECTION 6 5 5)
 472(test #t number? 3)
 473(test #t complex? 3)
 474(test #t real? 3)
 475(test #t rational? 3)
 476(test #t integer? 3)
 477
 478(test #t exact? 3)
 479(test #f inexact? 3)
 480
 481(test #t = 22 22 22)
 482(test #t = 22 22)
 483(test #f = 34 34 35)
 484(test #f = 34 35)
 485(test #t > 3 -6246)
 486(test #f > 9 9 -2424)
 487(test #t >= 3 -4 -6246)
 488(test #t >= 9 9)
 489(test #f >= 8 9)
 490(test #t < -1 2 3 4 5 6 7 8)
 491(test #f < -1 2 3 4 4 5 6 7)
 492(test #t <= -1 2 3 4 5 6 7 8)
 493(test #t <= -1 2 3 4 4 5 6 7)
 494(test #f < 1 3 2)
 495(test #f >= 1 3 2)
 496
 497(test #t zero? 0)
 498(test #f zero? 1)
 499(test #f zero? -1)
 500(test #f zero? -100)
 501(test #t positive? 4)
 502(test #f positive? -4)
 503(test #f positive? 0)
 504(test #f negative? 4)
 505(test #t negative? -4)
 506(test #f negative? 0)
 507(test #t odd? 3)
 508(test #f odd? 2)
 509(test #f odd? -4)
 510(test #t odd? -1)
 511(test #f even? 3)
 512(test #t even? 2)
 513(test #t even? -4)
 514(test #f even? -1)
 515
 516(test 38 max 34 5 7 38 6)
 517(test -24 min 3  5 5 330 4 -24)
 518
 519(test 7 + 3 4)
 520(test '3 + 3)
 521(test 0 +)
 522(test 4 * 4)
 523(test 1 *)
 524
 525(test -1 - 3 4)
 526(test -3 - 3)
 527(test 7 abs -7)
 528(test 7 abs 7)
 529(test 0 abs 0)
 530
 531(test 5 quotient 35 7)
 532(test -5 quotient -35 7)
 533(test -5 quotient 35 -7)
 534(test 5 quotient -35 -7)
 535(test 1 modulo 13 4)
 536(test 1 remainder 13 4)
 537(test 3 modulo -13 4)
 538(test -1 remainder -13 4)
 539(test -3 modulo 13 -4)
 540(test 1 remainder 13 -4)
 541(test -1 modulo -13 -4)
 542(test -1 remainder -13 -4)
 543(test 0 modulo 0 86400)
 544(test 0 modulo 0 -86400)
 545(define (divtest n1 n2)
 546	(= n1 (+ (* n2 (quotient n1 n2))
 547		 (remainder n1 n2))))
 548(test #t divtest 238 9)
 549(test #t divtest -238 9)
 550(test #t divtest 238 -9)
 551(test #t divtest -238 -9)
 552
 553(test 4 gcd 0 4)
 554(test 4 gcd -4 0)
 555(test 4 gcd 32 -36)
 556(test 0 gcd)
 557(test 288 lcm 32 -36)
 558(test 1 lcm)
 559
 560(SECTION 6 5 5)
 561;;; Implementations which don't allow division by 0 can have fragile
 562;;; string->number.
 563(define (test-string->number str)
 564  (define ans (string->number str))
 565  (cond ((not ans) #t) ((number? ans) #t) (else ans)))
 566(for-each (lambda (str) (test #t test-string->number str))
 567	  '("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0"
 568	    "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i"
 569	    "#i" "#e" "#" "#i0/0"))
 570(cond ((number? (string->number "1+1i")) ;More kawa bait
 571       (test #t number? (string->number "#i-i"))
 572       (test #t number? (string->number "#i+i"))
 573       (test #t number? (string->number "#i2+i"))))
 574
 575;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
 576;;; Modified by jaffer.
 577(define (test-inexact)
 578  (define f3.9 (string->number "3.9"))
 579  (define f4.0 (string->number "4.0"))
 580  (define f-3.25 (string->number "-3.25"))
 581  (define f.25 (string->number ".25"))
 582  (define f4.5 (string->number "4.5"))
 583  (define f3.5 (string->number "3.5"))
 584  (define f0.0 (string->number "0.0"))
 585  (define f0.8 (string->number "0.8"))
 586  (define f1.0 (string->number "1.0"))
 587  (define wto write-test-obj)
 588  (define lto load-test-obj)
 589  (newline)
 590  (display ";testing inexact numbers; ")
 591  (newline)
 592  (SECTION 6 2)
 593  (test #f eqv? 1 f1.0)
 594  (test #f eqv? 0 f0.0)
 595  (SECTION 6 5 5)
 596  (test #t inexact? f3.9)
 597  (test #t 'max (inexact? (max f3.9 4)))
 598  (test f4.0 max f3.9 4)
 599  (test f4.0 exact->inexact 4)
 600  (test f4.0 exact->inexact 4.0)
 601  (test 4 inexact->exact 4)
 602  (test 4 inexact->exact 4.0)
 603  (test (- f4.0) round (- f4.5))
 604  (test (- f4.0) round (- f3.5))
 605  (test (- f4.0) round (- f3.9))
 606  (test f0.0 round f0.0)
 607  (test f0.0 round f.25)
 608  (test f1.0 round f0.8)
 609  (test f4.0 round f3.5)
 610  (test f4.0 round f4.5)
 611  (test 1 expt 0 0)
 612  (test 0 expt 0 1)
 613  (test (atan 1) atan 1 1)
 614  (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
 615  (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
 616  (test #t call-with-output-file
 617      "tmp3.out"
 618      (lambda (test-file)
 619	(write-char #\; test-file)
 620	(display #\; test-file)
 621	(display ";" test-file)
 622	(write write-test-obj test-file)
 623	(newline test-file)
 624	(write load-test-obj test-file)
 625	(output-port? test-file)))
 626  (check-test-file "tmp3.out")
 627  (set! write-test-obj wto)
 628  (set! load-test-obj lto)
 629  (let ((x (string->number "4195835.0"))
 630	(y (string->number "3145727.0")))
 631    (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
 632  (report-errs))
 633
 634(define (test-inexact-printing)
 635  (let ((f0.0 (string->number "0.0"))
 636	(f0.5 (string->number "0.5"))
 637	(f1.0 (string->number "1.0"))
 638	(f2.0 (string->number "2.0")))
 639    (define log2
 640      (let ((l2 (log 2)))
 641	(lambda (x) (/ (log x) l2))))
 642
 643    (define (slow-frexp x)
 644      (if (zero? x)
 645	  (list f0.0 0)
 646	  (let* ((l2 (log2 x))
 647		 (e (floor (log2 x)))
 648		 (e (if (= l2 e)
 649			(inexact->exact e)
 650			(+ (inexact->exact e) 1)))
 651		 (f (/ x (expt 2 e))))
 652	    (list f e))))
 653
 654    (define float-precision
 655      (let ((mantissa-bits
 656	     (do ((i 0 (+ i 1))
 657		  (eps f1.0 (* f0.5 eps)))
 658		 ((= f1.0 (+ f1.0 eps))
 659		  i)))
 660	    (minval
 661	     (do ((x f1.0 (* f0.5 x)))
 662		 ((zero? (* f0.5 x)) x))))
 663	(lambda (x)
 664	  (apply (lambda (f e)
 665		   (let ((eps
 666			  (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits))))
 667				((zero? f) minval)
 668				(else (expt f2.0 (- e mantissa-bits))))))
 669		     (if (zero? eps)	;Happens if gradual underflow.
 670			 minval
 671			 eps)))
 672		 (slow-frexp x)))))
 673
 674    (define (float-print-test x)
 675      (define (testit number)
 676	(eqv? number (string->number (number->string number))))
 677      (let ((eps (float-precision x))
 678	    (all-ok? #t))
 679	(do ((j -100 (+ j 1)))
 680	    ((or (not all-ok?) (> j 100)) all-ok?)
 681	  (let* ((xx (+ x (* j eps)))
 682		 (ok? (testit xx)))
 683	    (cond ((not ok?)
 684		   (display "Number readback failure for ")
 685		   (display `(+ ,x (* ,j ,eps)))
 686		   (newline)
 687		   (display xx)
 688		   (newline)
 689		   (set! all-ok? #f))
 690		  ;;   (else (display xx) (newline))
 691		  )))))
 692
 693    (define (mult-float-print-test x)
 694      (let ((res #t))
 695	(for-each
 696	 (lambda (mult)
 697	   (or (float-print-test (* mult x)) (set! res #f)))
 698	 (map string->number
 699	      '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100"
 700		"0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100")))
 701	res))
 702
 703    (SECTION 6 5 6)
 704    (test #t 'float-print-test (float-print-test f0.0))
 705    (test #t 'mult-float-print-test (mult-float-print-test f1.0))
 706    (test #t 'mult-float-print-test (mult-float-print-test
 707				     (string->number "3.0")))
 708    (test #t 'mult-float-print-test (mult-float-print-test
 709				     (string->number "7.0")))
 710    (test #t 'mult-float-print-test (mult-float-print-test
 711				     (string->number "3.1415926535897931")))
 712    (test #t 'mult-float-print-test (mult-float-print-test
 713				     (string->number "2.7182818284590451")))))
 714
 715(define (test-bignum)
 716  (define tb
 717    (lambda (n1 n2)
 718      (= n1 (+ (* n2 (quotient n1 n2))
 719	       (remainder n1 n2)))))
 720  (newline)
 721  (display ";testing bignums; ")
 722  (newline)
 723  (SECTION 6 5 7)
 724  (test 0 modulo 33333333333333333333 3)
 725  (test 0 modulo 33333333333333333333 -3)
 726  (test 0 remainder 33333333333333333333 3)
 727  (test 0 remainder 33333333333333333333 -3)
 728  (test 2 modulo 33333333333333333332 3)
 729  (test -1 modulo 33333333333333333332 -3)
 730  (test 2 remainder 33333333333333333332 3)
 731  (test 2 remainder 33333333333333333332 -3)
 732  (test 1 modulo -33333333333333333332 3)
 733  (test -2 modulo -33333333333333333332 -3)
 734  (test -2 remainder -33333333333333333332 3)
 735  (test -2 remainder -33333333333333333332 -3)
 736
 737  (test 3 modulo 3 33333333333333333333)
 738  (test 33333333333333333330 modulo -3 33333333333333333333)
 739  (test 3 remainder 3 33333333333333333333)
 740  (test -3 remainder -3 33333333333333333333)
 741  (test -33333333333333333330 modulo 3 -33333333333333333333)
 742  (test -3 modulo -3 -33333333333333333333)
 743  (test 3 remainder 3 -33333333333333333333)
 744  (test -3 remainder -3 -33333333333333333333)
 745
 746  (test 0 modulo -2177452800 86400)
 747  (test 0 modulo 2177452800 -86400)
 748  (test 0 modulo 2177452800 86400)
 749  (test 0 modulo -2177452800 -86400)
 750  (test 0 modulo  0 -2177452800)
 751  (test #t 'remainder (tb 281474976710655325431 65535))
 752  (test #t 'remainder (tb 281474976710655325430 65535))
 753
 754  (SECTION 6 5 8)
 755  (test 281474976710655325431 string->number "281474976710655325431")
 756  (test "281474976710655325431" number->string 281474976710655325431)
 757  (report-errs))
 758
 759(define (test-numeric-predicates)
 760  (display "Skipping bignum-inexact comparisons due to printing inconsistencies")
 761  ;; Windows prints the exponent with a leading zero, so the diff will break
 762  #;(let* ((big-ex (expt 2 90))
 763	   (big-inex (exact->inexact big-ex)))
 764      (newline)
 765      (display ";testing bignum-inexact comparisons;")
 766      (newline)
 767      (SECTION 6 5 5)
 768      (test #f = (+ big-ex 1) big-inex (- big-ex 1))
 769      (test #f = big-inex (+ big-ex 1) (- big-ex 1))
 770      (test #t < (- (inexact->exact big-inex) 1)
 771	    big-inex
 772	    (+ (inexact->exact big-inex) 1))))
 773
 774
 775(SECTION 6 5 9)
 776(test "0" number->string 0)
 777(test "100" number->string 100)
 778(test "100" number->string 256 16)
 779(test 100 string->number "100")
 780(test 256 string->number "100" 16)
 781(test #f string->number "")
 782(test #f string->number ".")
 783(test #f string->number "d")
 784(test #f string->number "D")
 785(test #f string->number "i")
 786(test #f string->number "I")
 787(test #f string->number "3i")
 788(test #f string->number "3I")
 789(test #f string->number "33i")
 790(test #f string->number "33I")
 791(test #f string->number "3.3i")
 792(test #f string->number "3.3I")
 793(test #f string->number "-")
 794(test #f string->number "+")
 795(test #t 'string->number (or (not (string->number "80000000" 16))
 796			     (positive? (string->number "80000000" 16))))
 797(test #t 'string->number (or (not (string->number "-80000000" 16))
 798			     (negative? (string->number "-80000000" 16))))
 799
 800(SECTION 6 6)
 801;(test #t eqv? '#\  #\Space)
 802;(test #t eqv? #\space '#\Space)
 803(test #t char? #\a)
 804(test #t char? #\()
 805(test #t char? #\ )
 806(test #t char? '#\newline)
 807
 808(test #f char=? #\A #\B)
 809(test #f char=? #\a #\b)
 810(test #f char=? #\9 #\0)
 811(test #t char=? #\A #\A)
 812
 813(test #t char<? #\A #\B)
 814(test #t char<? #\a #\b)
 815(test #f char<? #\9 #\0)
 816(test #f char<? #\A #\A)
 817
 818(test #f char>? #\A #\B)
 819(test #f char>? #\a #\b)
 820(test #t char>? #\9 #\0)
 821(test #f char>? #\A #\A)
 822
 823(test #t char<=? #\A #\B)
 824(test #t char<=? #\a #\b)
 825(test #f char<=? #\9 #\0)
 826(test #t char<=? #\A #\A)
 827
 828(test #f char>=? #\A #\B)
 829(test #f char>=? #\a #\b)
 830(test #t char>=? #\9 #\0)
 831(test #t char>=? #\A #\A)
 832
 833(test #f char-ci=? #\A #\B)
 834(test #f char-ci=? #\a #\B)
 835(test #f char-ci=? #\A #\b)
 836(test #f char-ci=? #\a #\b)
 837(test #f char-ci=? #\9 #\0)
 838(test #t char-ci=? #\A #\A)
 839(test #t char-ci=? #\A #\a)
 840
 841(test #t char-ci<? #\A #\B)
 842(test #t char-ci<? #\a #\B)
 843(test #t char-ci<? #\A #\b)
 844(test #t char-ci<? #\a #\b)
 845(test #f char-ci<? #\9 #\0)
 846(test #f char-ci<? #\A #\A)
 847(test #f char-ci<? #\A #\a)
 848
 849(test #f char-ci>? #\A #\B)
 850(test #f char-ci>? #\a #\B)
 851(test #f char-ci>? #\A #\b)
 852(test #f char-ci>? #\a #\b)
 853(test #t char-ci>? #\9 #\0)
 854(test #f char-ci>? #\A #\A)
 855(test #f char-ci>? #\A #\a)
 856
 857(test #t char-ci<=? #\A #\B)
 858(test #t char-ci<=? #\a #\B)
 859(test #t char-ci<=? #\A #\b)
 860(test #t char-ci<=? #\a #\b)
 861(test #f char-ci<=? #\9 #\0)
 862(test #t char-ci<=? #\A #\A)
 863(test #t char-ci<=? #\A #\a)
 864
 865(test #f char-ci>=? #\A #\B)
 866(test #f char-ci>=? #\a #\B)
 867(test #f char-ci>=? #\A #\b)
 868(test #f char-ci>=? #\a #\b)
 869(test #t char-ci>=? #\9 #\0)
 870(test #t char-ci>=? #\A #\A)
 871(test #t char-ci>=? #\A #\a)
 872
 873(test #t char-alphabetic? #\a)
 874(test #t char-alphabetic? #\A)
 875(test #t char-alphabetic? #\z)
 876(test #t char-alphabetic? #\Z)
 877(test #f char-alphabetic? #\0)
 878(test #f char-alphabetic? #\9)
 879(test #f char-alphabetic? #\space)
 880(test #f char-alphabetic? #\;)
 881
 882(test #f char-numeric? #\a)
 883(test #f char-numeric? #\A)
 884(test #f char-numeric? #\z)
 885(test #f char-numeric? #\Z)
 886(test #t char-numeric? #\0)
 887(test #t char-numeric? #\9)
 888(test #f char-numeric? #\space)
 889(test #f char-numeric? #\;)
 890
 891(test #f char-whitespace? #\a)
 892(test #f char-whitespace? #\A)
 893(test #f char-whitespace? #\z)
 894(test #f char-whitespace? #\Z)
 895(test #f char-whitespace? #\0)
 896(test #f char-whitespace? #\9)
 897(test #t char-whitespace? #\space)
 898(test #f char-whitespace? #\;)
 899
 900(test #f char-upper-case? #\0)
 901(test #f char-upper-case? #\9)
 902(test #f char-upper-case? #\space)
 903(test #f char-upper-case? #\;)
 904
 905(test #f char-lower-case? #\0)
 906(test #f char-lower-case? #\9)
 907(test #f char-lower-case? #\space)
 908(test #f char-lower-case? #\;)
 909
 910(test #\. integer->char (char->integer #\.))
 911(test #\A integer->char (char->integer #\A))
 912(test #\a integer->char (char->integer #\a))
 913(test #\A char-upcase #\A)
 914(test #\A char-upcase #\a)
 915(test #\a char-downcase #\A)
 916(test #\a char-downcase #\a)
 917(SECTION 6 7)
 918(test #t string? "The word \"recursion\\\" has many meanings.")
 919;(test #t string? "")
 920(define f (make-string 3 #\*))
 921(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
 922(test "abc" string #\a #\b #\c)
 923(test "" string)
 924(test 3 string-length "abc")
 925(test #\a string-ref "abc" 0)
 926(test #\c string-ref "abc" 2)
 927(test 0 string-length "")
 928(test "" substring "ab" 0 0)
 929(test "" substring "ab" 1 1)
 930(test "" substring "ab" 2 2)
 931(test "a" substring "ab" 0 1)
 932(test "b" substring "ab" 1 2)
 933(test "ab" substring "ab" 0 2)
 934(test "foobar" string-append "foo" "bar")
 935(test "foo" string-append "foo")
 936(test "foo" string-append "foo" "")
 937(test "foo" string-append "" "foo")
 938(test "" string-append)
 939(test "" make-string 0)
 940(test #t string=? "" "")
 941(test #f string<? "" "")
 942(test #f string>? "" "")
 943(test #t string<=? "" "")
 944(test #t string>=? "" "")
 945(test #t string-ci=? "" "")
 946(test #f string-ci<? "" "")
 947(test #f string-ci>? "" "")
 948(test #t string-ci<=? "" "")
 949(test #t string-ci>=? "" "")
 950
 951(test #f string=? "A" "B")
 952(test #f string=? "a" "b")
 953(test #f string=? "9" "0")
 954(test #t string=? "A" "A")
 955
 956(test #t string<? "A" "B")
 957(test #t string<? "a" "b")
 958(test #f string<? "9" "0")
 959(test #f string<? "A" "A")
 960
 961(test #f string>? "A" "B")
 962(test #f string>? "a" "b")
 963(test #t string>? "9" "0")
 964(test #f string>? "A" "A")
 965
 966(test #t string<=? "A" "B")
 967(test #t string<=? "a" "b")
 968(test #f string<=? "9" "0")
 969(test #t string<=? "A" "A")
 970
 971(test #f string>=? "A" "B")
 972(test #f string>=? "a" "b")
 973(test #t string>=? "9" "0")
 974(test #t string>=? "A" "A")
 975
 976(test #f string-ci=? "A" "B")
 977(test #f string-ci=? "a" "B")
 978(test #f string-ci=? "A" "b")
 979(test #f string-ci=? "a" "b")
 980(test #f string-ci=? "9" "0")
 981(test #t string-ci=? "A" "A")
 982(test #t string-ci=? "A" "a")
 983
 984(test #t string-ci<? "A" "B")
 985(test #t string-ci<? "a" "B")
 986(test #t string-ci<? "A" "b")
 987(test #t string-ci<? "a" "b")
 988(test #f string-ci<? "9" "0")
 989(test #f string-ci<? "A" "A")
 990(test #f string-ci<? "A" "a")
 991
 992(test #f string-ci>? "A" "B")
 993(test #f string-ci>? "a" "B")
 994(test #f string-ci>? "A" "b")
 995(test #f string-ci>? "a" "b")
 996(test #t string-ci>? "9" "0")
 997(test #f string-ci>? "A" "A")
 998(test #f string-ci>? "A" "a")
 999
 1000(test #t string-ci<=? "A" "B")
1001(test #t string-ci<=? "a" "B")
1002(test #t string-ci<=? "A" "b")
1003(test #t string-ci<=? "a" "b")
1004(test #f string-ci<=? "9" "0")
1005(test #t string-ci<=? "A" "A")
1006(test #t string-ci<=? "A" "a")
1007
1008(test #f string-ci>=? "A" "B")
1009(test #f string-ci>=? "a" "B")
1010(test #f string-ci>=? "A" "b")
1011(test #f string-ci>=? "a" "b")
1012(test #t string-ci>=? "9" "0")
1013(test #t string-ci>=? "A" "A")
1014(test #t string-ci>=? "A" "a")
1015(SECTION 6 8)
1016(test #t vector? '#(0 (2 2 2 2) "Anna"))
1017;(test #t vector? '#())
1018(test '#(a b c) vector 'a 'b 'c)
1019(test '#() vector)
1020(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
1021(test 0 vector-length '#())
1022(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
1023(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
1024	(let ((vec (vector 0 '(2 2 2 2) "Anna")))
1025	  (vector-set! vec 1 '("Sue" "Sue"))
1026	  vec))
1027(test '#(hi hi) make-vector 2 'hi)
1028(test '#() make-vector 0)
1029(test '#() make-vector 0 'a)
1030(SECTION 6 9)
1031(test #t procedure? car)
1032;(test #f procedure? 'car)
1033(test #t procedure? (lambda (x) (* x x)))
1034(test #f procedure? '(lambda (x) (* x x)))
1035(test #t call-with-current-continuation procedure?)
1036(test 7 apply + (list 3 4))
1037(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
1038(test 17 apply + 10 (list 3 4))
1039(test '() apply list '())
1040(define compose (lambda (f g) (lambda args (f (apply g args)))))
1041(test 30 (compose sqt *) 12 75)
1042
1043(test '(b e h) map cadr '((a b) (d e) (g h)))
1044(test '(5 7 9) map + '(1 2 3) '(4 5 6))
1045(test '(1 2 3) map + '(1 2 3))
1046(test '(1 2 3) map * '(1 2 3))
1047(test '(-1 -2 -3) map - '(1 2 3))
1048(test '#(0 1 4 9 16) 'for-each
1049      (let ((v (make-vector 5)))
1050	(for-each (lambda (i) (vector-set! v i (* i i)))
1051		  '(0 1 2 3 4))
1052	v))
1053(test -3 call-with-current-continuation
1054      (lambda (exit)
1055	(for-each (lambda (x) (if (negative? x) (exit x)))
1056		  '(54 0 37 -3 245 19))
1057	#t))
1058(define list-length
1059 (lambda (obj)
1060  (call-with-current-continuation
1061   (lambda (return)
1062    (letrec ((r (lambda (obj) (cond ((null? obj) 0)
1063				((pair? obj) (+ (r (cdr obj)) 1))
1064				(else (return #f))))))
1065	(r obj))))))
1066(test 4 list-length '(1 2 3 4))
1067(test #f list-length '(a b . c))
1068(test '() map cadr '())
1069
1070;;; This tests full conformance of call-with-current-continuation.  It
1071;;; is a separate test because some schemes do not support call/cc
1072;;; other than escape procedures.  I am indebted to
1073;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
1074;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
1075;;; trees constructed of conses.
1076(define (next-leaf-generator obj eot)
1077  (letrec ((return #f)
1078	   (cont (lambda (x)
1079		   (recur obj)
1080		   (set! cont (lambda (x) (return eot)))
1081		   (cont #f)))
1082	   (recur (lambda (obj)
1083		      (if (pair? obj)
1084			  (for-each recur obj)
1085			  (call-with-current-continuation
1086			   (lambda (c)
1087			     (set! cont c)
1088			     (return obj)))))))
1089    (lambda () (call-with-current-continuation
1090		(lambda (ret) (set! return ret) (cont #f))))))
1091(define (leaf-eq? x y)
1092  (let* ((eot (list 'eot))
1093	 (xf (next-leaf-generator x eot))
1094	 (yf (next-leaf-generator y eot)))
1095    (letrec ((loop (lambda (x y)
1096		     (cond ((not (eq? x y)) #f)
1097			   ((eq? eot x) #t)
1098			   (else (loop (xf) (yf)))))))
1099      (loop (xf) (yf)))))
1100(define (test-cont)
1101  (newline)
1102  (display ";testing continuations; ")
1103  (newline)
1104  (SECTION 6 9)
1105  (test #t leaf-eq? '(a (b (c))) '((a) b c))
1106  (test #f leaf-eq? '(a (b (c))) '((a) b c d))
1107  (report-errs))
1108
1109;;; Test Optional R4RS DELAY syntax and FORCE procedure
1110(define (test-delay)
1111  (newline)
1112  (display ";testing DELAY and FORCE; ")
1113  (newline)
1114  (SECTION 6 9)
1115  (test 3 'delay (force (delay (+ 1 2))))
1116  (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
1117			(list (force p) (force p))))
1118  (test 2 'delay (letrec ((a-stream
1119			   (letrec ((next (lambda (n)
1120					    (cons n (delay (next (+ n 1)))))))
1121			     (next 0)))
1122			  (head car)
1123			  (tail (lambda (stream) (force (cdr stream)))))
1124		   (head (tail (tail a-stream)))))
1125  (letrec ((count 0)
1126	   (p (delay (begin (set! count (+ count 1))
1127			    (if (> count x)
1128				count
1129				(force p)))))
1130	   (x 5))
1131    (test 6 force p)
1132    (set! x 10)
1133    (test 6 force p))
1134  (test 3 'force
1135	(letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
1136		 (c #f))
1137	  (force p)))
1138  (report-errs))
1139
1140(SECTION 6 10 1)
1141(test #t input-port? (current-input-port))
1142(test #t output-port? (current-output-port))
1143(test #t call-with-input-file "r4rstest.scm" input-port?)
1144(define this-file (open-input-file "r4rstest.scm"))
1145(test #t input-port? this-file)
1146(SECTION 6 10 2)
1147(test #\; peek-char this-file)
1148(test #\; read-char this-file)
1149(test '(define cur-section '()) read this-file)
1150(test #\( peek-char this-file)
1151(test '(define errs '()) read this-file)
1152(close-input-port this-file)
1153(close-input-port this-file)
1154(define (check-test-file name)
1155  (define test-file (open-input-file name))
1156  (test #t 'input-port?
1157	(call-with-input-file
1158	    name
1159	  (lambda (test-file)
1160	    (test load-test-obj read test-file)
1161	    (test #t eof-object? (peek-char test-file))
1162	    (test #t eof-object? (read-char test-file))
1163	    (input-port? test-file))))
1164  (test #\; read-char test-file)
1165  (test #\; read-char test-file)
1166  (test #\; read-char test-file)
1167  (test write-test-obj read test-file)
1168  (test load-test-obj read test-file)
1169  (close-input-port test-file))
1170(SECTION 6 10 3)
1171(define write-test-obj
1172  '(#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
1173(define load-test-obj
1174  (list 'define 'foo (list 'quote write-test-obj)))
1175(test #t call-with-output-file
1176      "tmp1.out"
1177      (lambda (test-file)
1178	(write-char #\; test-file)
1179	(display #\; test-file)
1180	(display ";" test-file)
1181	(write write-test-obj test-file)
1182	(newline test-file)
1183	(write load-test-obj test-file)
1184	(output-port? test-file)))
1185(check-test-file "tmp1.out")
1186
1187(define test-file (open-output-file "tmp2.out"))
1188(write-char #\; test-file)
1189(display #\; test-file)
1190(display ";" test-file)
1191(write write-test-obj test-file)
1192(newline test-file)
1193(write load-test-obj test-file)
1194(test #t output-port? test-file)
1195(close-output-port test-file)
1196(check-test-file "tmp2.out")
1197(define (test-sc4)
1198  (newline)
1199  (display ";testing scheme 4 functions; ")
1200  (newline)
1201  (SECTION 6 7)
1202  (test '(#\P #\space #\l) string->list "P l")
1203  (test '() string->list "")
1204  (test "1\\\"" list->string '(#\1 #\\ #\"))
1205  (test "" list->string '())
1206  (SECTION 6 8)
1207  (test '(dah dah didah) vector->list '#(dah dah didah))
1208  (test '() vector->list '#())
1209  (test '#(dididit dah) list->vector '(dididit dah))
1210  (test '#() list->vector '())
1211  (SECTION 6 10 4)
1212  (load "tmp1.out")
1213  (test write-test-obj 'load foo)
1214  (report-errs))
1215
1216(report-errs)
1217(let ((have-inexacts?
1218       (and (string->number "0.0") (inexact? (string->number "0.0"))))
1219      (have-bignums?
1220       (let ((n (string->number "281474976710655325431")))
1221	 (and n (exact? n)))))
1222  (cond (have-inexacts?
1223	 (test-inexact)
1224	 #;(test-inexact-printing)))
1225  (if have-bignums? (test-bignum))
1226  (if (and have-inexacts? have-bignums?)
1227      (test-numeric-predicates)))
1228
1229(newline)
1230(display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
1231(newline)
1232(display "(test-cont) (test-sc4) (test-delay)")
1233(newline)
1234(test-cont)
1235(test-sc4)
1236(test-delay)
1237"last item in file"