Kawa/testsuite/test.scm

;;;; `test.scm' Test correctness of scheme implementations.
;;; ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003 Free Software Foundation, Inc.

;;;; "r4rstest.scm" Test correctness of scheme implementations.
;;; Author: Aubrey Jaffer
;;; Modified for Kawa testing framework by Per Bothner 1996-2003.

;;; This includes examples from
;;; William Clinger and Jonathan Rees, editors.
;;; Revised^4 Report on the Algorithmic Language Scheme
;;; and the IEEE specification.

;;; The input tests read this file expecting it to be named "test.scm".
;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
;;; these tests.  You may need to delete them in order to run
;;; "test.scm" more than once.

;;;   There are three optional tests:
;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
;;; 
;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
;;; 
;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
;;;   either standard.

;;; If you are testing a R3RS version which does not have `list?' do:
;;; (define list? #f)

;;; send corrections or additions to jaffer@ai.mit.edu or
;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA

(TEST-INIT "scm-test" 617)(define errs '())

;(define test
;  (lambda (expect fun . args)
;    (write (cons fun args))
;    (display "  ==> ")
;    ((lambda (res)
;      (write res)
;      (newline)
;      (cond ((not (equal? expect res))
;             (record-error (list res expect (cons fun args)))
;             (display " BUT EXPECTED ")
;             (write expect)
;             (newline)
;             #f)
;            (else #t)))
;     (if (procedure? fun) (apply fun args) (car args)))))
(define (report-errs) #t)
;(define (report-errs)
;  (newline)
;  (if (null? errs) (display "Passed all tests")
;      (begin
;        (display "errors were:")
;        (newline)
;        (display "(SECTION (got expected (call)))")
;        (newline)
;        (for-each (lambda (l) (write l) (newline))
;                  errs)))
;  (newline))

(define *out-port* (or *log-file* (current-output-port)))

(SECTION 2 1);; test that all symbol characters are supported.
'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)

(SECTION 3 4)
(define disjoint-type-functions
  (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
(define type-examples
  (list
   #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
(define i 1)
(for-each (lambda (x) (display (make-string i #\ ) *out-port*)
                  (set! i (+ 3 i))
                  (write x *out-port*)
                  (newline *out-port*))
          disjoint-type-functions)
(define type-matrix
  (map (lambda (x)
         (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
           (write t *out-port*)
           (write x *out-port*)
           (newline *out-port*)
           t))
       type-examples))
#|
(set! i 0)
(define j 0)
(for-each (lambda (x y)
	    (set! j (+ 1 j))
	    (set! i 0)
	    (for-each (lambda (f)
			(set! i (+ 1 i))
			(cond ((and (= i j))
			       (cond ((not (f x)) (test #t f x))))
			      ((f x) (test #f f x)))
			(cond ((and (= i j))
			       (cond ((not (f y)) (test #t f y))))
			      ((f y) (test #f f y))))
		      disjoint-type-functions))
	  (list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c))
	  (list #f #\newline '() -3252 '(t . t) car "" 'nil '#()))
|#
(SECTION "4 1 2")
(test '(quote a) 'quote (quote 'a))
(test '(quote a) 'quote ''a)
(SECTION "4 1 3")
(test 12 (if #f + *) 3 4)
(SECTION 4 1 4)
(test 8 (lambda (x) (+ x x)) 4)
(define reverse-subtract
  (lambda (x y) (- y x)))
(test 3 reverse-subtract 7 10)
(define add4
  (let ((x 4))
    (lambda (y) (+ x y))))
(test 10 add4 6)
(test '(3 4 5 6) (lambda x x) 3 4 5 6)
(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
(SECTION 4 1 5)
(test 'yes 'if (if (> 3 2) 'yes 'no))
(test 'no 'if (if (> 2 3) 'yes 'no))
(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
(SECTION 4 1 6)
(define x 2)
(test 3 'define (+ x 1))
(set! x 4)
(test 5 'set! (+ x 1))
(SECTION 4 2 1)
;; Moved to bad-voidexp.scm
;;(test 'greater 'cond (cond ((> 3 2) 'greater)
;;                           ((< 3 2) 'less)))
(test 'equal 'cond (cond ((> 3 3) 'greater)
                         ((< 3 3) 'less)
                         (else 'equal)))
(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
                     (else #f)))
(test #t 'cond (cond (#t) (3 4)))
;; Moved to bad-voidexp.scm
;;(test 'composite 'case (case (* 2 3)
;;                         ((2 3 5 7) 'prime)
;;                         ((1 4 6 8 9) 'composite)))
(test 'consonant 'case (case (car '(c d))
                         ((a e i o u) 'vowel)
                         ((w y) 'semivowel)
                         (else 'consonant)))
(test #t 'and (and (= 2 2) (> 2 1)))
(test #f 'and (and (= 2 2) (< 2 1)))
(test '(f g) 'and (and 1 2 'c '(f g)))
(test #t 'and (and))
(test #t 'or (or (= 2 2) (> 2 1)))
(test #t 'or (or (= 2 2) (< 2 1)))
(test #f 'or (or #f #f #f))
(test #f 'or (or))
(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
(SECTION 4 2 2)
(test 6 'let (let ((x 2) (y 3)) (* x y)))
(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
(test #t 'letrec (letrec ((even?
                           (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
                          (odd?
                           (lambda (n) (if (zero? n) #f (even? (- n 1))))))
                   (even? 88)))
(define x 34)
(test 5 'let (let ((x 3)) (define x 5) x))
(test 34 'let x)
(test 6 'let (let () (define x 6) x))
(test 34 'let x)
(test 7 'let* (let* ((x 3)) (define x 7) x))
(test 34 'let* x)
(test 8 'let* (let* () (define x 8) x))
(test 34 'let* x)
(test 9 'letrec (letrec () (define x 9) x))
(test 34 'letrec x)
(test 10 'letrec (letrec ((x 3)) (define x 10) x))
(test 34 'letrec x)
(SECTION 4 2 3)
(define x 0)
(test 6 'begin (begin (set! x (begin (begin 5)))
		      (begin ((begin +) (begin x) (begin (begin 1))))))
(SECTION 4 2 4)
(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
                            (i 0 (+ i 1)))
                           ((= i 5) vec)
                         (vector-set! vec i i)))
(test 25 'do (let ((x '(1 3 5 7 9)))
               (do ((x x (cdr x))
                    (sum 0 (+ sum (car x))))
                   ((null? x) sum))))
(test 1 'let (let foo () 1))
(test '((6 1 3) (-5 -2)) 'let
      (let loop ((numbers '(3 -2 1 6 -5))
                 (nonneg '())
                 (neg '()))
        (cond ((null? numbers) (list nonneg neg))
              ((negative? (car numbers))
               (loop (cdr numbers)
                     nonneg
                     (cons (car numbers) neg)))
              (else
               (loop (cdr numbers)
                     (cons (car numbers) nonneg)
                     neg)))))
(SECTION 4 2 6)
(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
(test '((foo 7) . cons)
        'quasiquote
        `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))

;;; sqt is defined here because not all implementations are required to
;;; support it. 
(define (sqt x)
        (do ((i 0 (+ i 1)))
            ((> (* i i) x) (- i 1))))

(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
(test 5 'quasiquote `,(+ 2 3))
(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
      'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
(test '(a `(b ,x ,'y d) e) 'quasiquote
        (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
(SECTION 5 2 1)
;; some tests moved to define3.scm because they only work if --no-inline
(begin)
(begin (begin))
(begin (begin (begin (begin))))
(SECTION 5 2 2)
(test 45 'define
        (let ((x 5))
                (define foo (lambda (y) (bar x y)))
                (define bar (lambda (a b) (+ (* a b) a)))
                (foo (+ x 3))))
(define x 34)
(define (foo) (define x 5) x)
(test 5 foo)
(test 34 'define x)
(define foo (lambda () (define x 5) x))
(test 5 foo)
(test 34 'define x)
(define (foo x) ((lambda () (define x 5) x)) x)
(test 88 foo 88)
(test 4 foo 4)
(test 34 'define x)
(test 99 'internal-define (letrec ((foo (lambda (arg)
					  (or arg (and (procedure? foo)
						       (foo 99))))))
			    (define bar (foo #f))
			    (foo #f)))
(test 77 'internal-define (letrec ((foo 77)
				   (bar #f)
				   (retfoo (lambda () foo)))
			    (define baz (retfoo))
			    (retfoo)))
(SECTION 6 1)
(test #f not #t)
(test #f not 3)
(test #f not (list 3))
(test #t not #f)
(test #f not '())
(test #f not (list))
(test #f not 'nil)

(test #t boolean? #f)
(test #f boolean? 0)
(test #f boolean? '())
(SECTION 6 2)
(test #t eqv? 'a 'a)
(test #f eqv? 'a 'b)
(test #t eqv? 2 2)
(test #t eqv? '() '())
(test #t eqv? '10000 '10000)
(test #f eqv? (cons 1 2)(cons 1 2))
(test #f eqv? (lambda () 1) (lambda () 2))
(test #f eqv? #f 'nil)
(let ((p (lambda (x) x)))
  (test #t eqv? p p))
(define gen-counter
 (lambda ()
   (let ((n 0))
      (lambda () (set! n (+ n 1)) n))))
(let ((g (gen-counter))) (test #t eqv? g g))
(test #f eqv? (gen-counter) (gen-counter))
(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
         (g (lambda () (if (eqv? f g) 'g 'both))))
  (test #f eqv? f g))

(test #t eq? 'a 'a)
(test #f eq? (list 'a) (list 'a))
(test #t eq? '() '())
(test #t eq? car car)
(let ((x '(a))) (test #t eq? x x))
(let ((x '#())) (test #t eq? x x))
(let ((x (lambda (x) x))) (test #t eq? x x))

(define (eq?-eqv?-agreement obj1 obj2)
  (eq? (eq? obj1 obj2) (eqv? obj1 obj2)))
(define-syntax test-eq?-eqv?-agreement
  (syntax-rules ()
		((_ obj1 obj2)
		 (test #t eq?-eqv?-agreement obj1 obj2))))
(test-eq?-eqv?-agreement '#f '#f)
(test-eq?-eqv?-agreement '#t '#t)
(test-eq?-eqv?-agreement '#t '#f)
(test-eq?-eqv?-agreement '(a) '(a))
(test-eq?-eqv?-agreement '(a) '(b))
(test-eq?-eqv?-agreement car car)
(test-eq?-eqv?-agreement car cdr)
(test-eq?-eqv?-agreement (list 'a) (list 'a))
(test-eq?-eqv?-agreement (list 'a) (list 'b))
(test-eq?-eqv?-agreement '#(a) '#(a))
(test-eq?-eqv?-agreement '#(a) '#(b))
(test-eq?-eqv?-agreement "abc" "abc")
(test-eq?-eqv?-agreement "abc" "abz")

(test #t equal? 'a 'a)
(test #t equal? '(a) '(a))
(test #t equal? '(a (b) c) '(a (b) c))
(test #t equal? "abc" "abc")
(test #t equal? 2 2)
(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
(SECTION 6 3)
(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
(define x (list 'a 'b 'c))
(define y x)
(and list? (test #t list? y))
(set-cdr! x 4)
(test '(a . 4) 'set-cdr! x)
(test #t eqv? x y)
(test '(a b c . d) 'dot '(a . (b . (c . d))))
(and list? (test #f list? y))
(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))

(test #t pair? '(a . b))
(test #t pair? '(a . 1))
(test #t pair? '(a b c))
(test #f pair? '())
(test #f pair? '#(a b))

(test '(a) cons 'a '())
(test '((a) b c d) cons '(a) '(b c d))
(test '("a" b c) cons "a" '(b c))
(test '(a . 3) cons 'a 3)
(test '((a b) . c) cons '(a b) 'c)

(test 'a car '(a b c))
(test '(a) car '((a) b c d))
(test 1 car '(1 . 2))

(test '(b c d) cdr '((a) b c d))
(test 2 cdr '(1 . 2))

(test '(a 7 c) list 'a (+ 3 4) 'c)
(test '() list)

(test 3 length '(a b c))
(test 3 length '(a (b) (c d e)))
(test 0 length '())

(test '(x y) append '(x) '(y))
(test '(a b c d) append '(a) '(b c d))
(test '(a (b) (c)) append '(a (b)) '((c)))
(test '() append)
(test '(a b c . d) append '(a b) '(c . d))
(test 'a append '() 'a)

(test '(c b a) reverse '(a b c))
(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))

(test 'c list-ref '(a b c d) 2)

(test '(a b c) memq 'a '(a b c))
(test '(b c) memq 'b '(a b c))
(test '#f memq 'a '(b c d))
(test '#f memq (list 'a) '(b (a) c))
(test '((a) c) member (list 'a) '(b (a) c))
(test '(101 102) memv 101 '(100 101 102))

(define e '((a 1) (b 2) (c 3)))
(test '(a 1) assq 'a e)
(test '(b 2) assq 'b e)
(test #f assq 'd e)
(test #f assq (list 'a) '(((a)) ((b)) ((c))))
(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
(SECTION 6 4)
(test #t symbol? 'foo)
(test #t symbol? (car '(a b)))
(test #f symbol? "bar")
(test #t symbol? 'nil)
(test #f symbol? '())
(test #f symbol? #f)
;;; But first, what case are symbols in?  Determine the standard case:
(define char-standard-case char-upcase)
(if (string=? (symbol->string 'A) "a")
    (set! char-standard-case char-downcase))
(test #t 'standard-case
      (string=? (symbol->string 'a) (symbol->string 'A)))
(test #t 'standard-case
      (or (string=? (symbol->string 'a) "A")
	  (string=? (symbol->string 'A) "a")))
(define (str-copy s)
  (let ((v (make-string (string-length s))))
    (do ((i (- (string-length v) 1) (- i 1)))
        ((< i 0) v)
      (string-set! v i (string-ref s i)))))
(define (string-standard-case s)
  (set! s (str-copy s))
  (do ((i 0 (+ 1 i))
       (sl (string-length s)))
      ((>= i sl) s)
      (string-set! s i (char-standard-case (string-ref s i)))))
(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
(test (string-standard-case "martin") symbol->string 'Martin)
(test "Malvina" symbol->string (string->symbol "Malvina"))
(test #t 'standard-case (eq? 'a 'A))

(define x (string #\a #\b))
(define y (string->symbol x))
(string-set! x 0 #\c)
(test "cb" 'string-set! x)
(test "ab" symbol->string y)
(test y string->symbol "ab")

(test #t eq? 'mISSISSIppi 'mississippi)
(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
(test 'JollyWog string->symbol (symbol->string 'JollyWog))

(SECTION 6 5 5)
(test #t number? 3)
(test #t complex? 3)
(test #t real? 3)
(test #t rational? 3)
(test #t integer? 3)

(test #t exact? 3)
(test #f inexact? 3)

(test #t = 22 22 22)
(test #t = 22 22)
(test #f = 34 34 35)
(test #f = 34 35)
(test #t > 3 -6246)
(test #f > 9 9 -2424)
(test #t >= 3 -4 -6246)
(test #t >= 9 9)
(test #f >= 8 9)
(test #t < -1 2 3 4 5 6 7 8)
(test #f < -1 2 3 4 4 5 6 7)
(test #t <= -1 2 3 4 5 6 7 8)
(test #t <= -1 2 3 4 4 5 6 7)
(test #f < 1 3 2)
(test #f >= 1 3 2)

(test #t zero? 0)
(test #f zero? 1)
(test #f zero? -1)
(test #f zero? -100)
(test #t positive? 4)
(test #f positive? -4)
(test #f positive? 0)
(test #f negative? 4)
(test #t negative? -4)
(test #f negative? 0)
(test #t odd? 3)
(test #f odd? 2)
(test #f odd? -4)
(test #t odd? -1)
(test #f even? 3)
(test #t even? 2)
(test #t even? -4)
(test #f even? -1)

(test 38 max 34 5 7 38 6)
(test -24 min 3  5 5 330 4 -24)

(test 7 + 3 4)
(test '3 + 3)
(test 0 +)
(test 4 * 4)
(test 1 *)

(test -1 - 3 4)
(test -3 - 3)
(test 7 abs -7)
(test 7 abs 7)
(test 0 abs 0)

(test 5 quotient 35 7)
(test -5 quotient -35 7)
(test -5 quotient 35 -7)
(test 5 quotient -35 -7)
(test 1 modulo 13 4)
(test 1 remainder 13 4)
(test 3 modulo -13 4)
(test -1 remainder -13 4)
(test -3 modulo 13 -4)
(test 1 remainder 13 -4)
(test -1 modulo -13 -4)
(test -1 remainder -13 -4)
(test 0 modulo 0 86400)
(test 0 modulo 0 -86400)
(define (divtest n1 n2)
        (= n1 (+ (* n2 (quotient n1 n2))
                 (remainder n1 n2))))
(test #t divtest 238 9)
(test #t divtest -238 9)
(test #t divtest 238 -9)
(test #t divtest -238 -9)

(test 4 gcd 0 4)
(test 4 gcd -4 0)
(test 4 gcd 32 -36)
(test 0 gcd)
(test 288 lcm 32 -36)
(test 1 lcm)

(SECTION 6 5 5)
;;; Implementations which don't allow division by 0 can have fragile
;;; string->number.
(define (test-string->number str)
  (define ans (string->number str))
  (cond ((not ans) #t) ((number? ans) #t) (else ans)))
(for-each (lambda (str) (test #t test-string->number str))
	  '("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0"
	    "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i"))

;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
;;; Modified by jaffer.
(define (test-inexact)
  (define f3.9 (string->number "3.9"))
  (define f4.0 (string->number "4.0"))
  (define f-3.25 (string->number "-3.25"))
  (define f.25 (string->number ".25"))
  (define f4.5 (string->number "4.5"))
  (define f3.5 (string->number "3.5"))
  (define f0.0 (string->number "0.0"))
  (define f0.8 (string->number "0.8"))
  (define f1.0 (string->number "1.0"))
  (define wto write-test-obj)
  (define dto display-test-obj)
  (define lto load-test-obj)

  (SECTION 6 5 5 "(inexact numbers)")
  (test #t inexact? f3.9)
  (test #t 'inexact? (inexact? (max f3.9 4)))
  (test f4.0 'max (max f3.9 4))
  (test f4.0 'exact->inexact (exact->inexact 4))
  (test (- f4.0) round (- f4.5))
  (test (- f4.0) round (- f3.5))
  (test (- f4.0) round (- f3.9))
  (test f0.0 round f0.0)
  (test f0.0 round f.25)
  (test f1.0 round f0.8)
  (test f4.0 round f3.5)
  (test f4.0 round f4.5)
  (test 1 expt 0 0)
  (test 0 expt 0 1)
  (test (atan 1) atan 1 1)
  (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
  (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
  (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
  (test #t call-with-output-file
      "tmp3"
      (lambda (test-file)
        (write-char #\; test-file)
        (display write-test-obj test-file)
        (newline test-file)
        (write load-test-obj test-file)
        (output-port? test-file)))
  (check-test-file "tmp3")
  (set! write-test-obj wto)
  (set! display-test-obj dto)
  (set! load-test-obj lto)
  (let ((x (string->number "4195835.0"))
        (y (string->number "3145727.0")))
    (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
  (report-errs))

(define (test-inexact-printing)
  (let ((f0.0 (string->number "0.0"))
	(f0.5 (string->number "0.5"))
	(f1.0 (string->number "1.0"))
	(f2.0 (string->number "2.0")))
    (define log2
      (let ((l2 (log 2)))
	(lambda (x) (/ (log x) l2))))

    (define (slow-frexp x)
      (if (zero? x)
	  (list f0.0 0)
	  (let* ((l2 (log2 x))
		 (e (floor (log2 x)))
		 (e (if (= l2 e)
			(inexact->exact e)
			(+ (inexact->exact e) 1)))
		 (f (/ x (expt 2 e))))
	    (list f e))))

    (define float-precision
      (let ((mantissa-bits
	     (do ((i 0 (+ i 1))
		  (eps f1.0 (* f0.5 eps)))
		 ((= f1.0 (+ f1.0 eps))
		  i)))
	    (minval
	     (do ((x f1.0 (* f0.5 x)))
		 ((zero? (* f0.5 x)) x))))
	(lambda (x)
	  (apply (lambda (f e)
		   (let ((eps
			  (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits))))
				((zero? f) minval)
				(else (expt f2.0 (- e mantissa-bits))))))
		     (if (zero? eps)	;Happens if gradual underflow.
			 minval
			 eps)))
		 (slow-frexp x)))))

    (define (float-print-test x)
      (define (testit number)
	(eqv? number (string->number (number->string number))))
      (let ((eps (float-precision x))
	    (all-ok? #t))
	(do ((j -100 (+ j 1)))
	    ((or (not all-ok?) (> j 100)) all-ok?)
	  (let* ((xx (+ x (* j eps)))
		 (ok? (testit xx)))
	    (cond ((not ok?)
		   (display "Number readback failure for ")
		   (display `(+ ,x (* ,j ,eps)))
		   (newline)
		   (display xx)
		   (newline)
		   (set! all-ok? #f))
		  ;;   (else (display xx) (newline))
		  )))))

    (define (mult-float-print-test x)
      (let ((res #t))
	(for-each
	 (lambda (mult)
	   (or (float-print-test (* mult x)) (set! res #f)))
	 (map string->number
	      '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100"
		"0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100")))
	res))

    (SECTION 6 5 6)
    (test #t 'float-print-test (float-print-test f0.0))
    (test #t 'mult-float-print-test (mult-float-print-test f1.0))
    (test #t 'mult-float-print-test (mult-float-print-test
				     (string->number "3.0")))
    (test #t 'mult-float-print-test (mult-float-print-test
				     (string->number "7.0")))
    (test #t 'mult-float-print-test (mult-float-print-test
				     (string->number "3.1415926535897931")))
    (test #t 'mult-float-print-test (mult-float-print-test
				     (string->number "2.7182818284590451")))))
(define (test-bignum)
  (define tb
    (lambda (n1 n2)
      (= n1 (+ (* n2 (quotient n1 n2))
               (remainder n1 n2)))))
  (SECTION "6 5 5 (bignums)")
  (test 0 modulo 33333333333333333333 3)
  (test 0 modulo 33333333333333333333 -3)
  (test 0 remainder 33333333333333333333 3)
  (test 0 remainder 33333333333333333333 -3)
  (test 2 modulo 33333333333333333332 3)
  (test -1 modulo 33333333333333333332 -3)
  (test 2 remainder 33333333333333333332 3)
  (test 2 remainder 33333333333333333332 -3)
  (test 1 modulo -33333333333333333332 3)
  (test -2 modulo -33333333333333333332 -3)
  (test -2 remainder -33333333333333333332 3)
  (test -2 remainder -33333333333333333332 -3)

  (test 3 modulo 3 33333333333333333333)
  (test 33333333333333333330 modulo -3 33333333333333333333)
  (test 3 remainder 3 33333333333333333333)
  (test -3 remainder -3 33333333333333333333)
  (test -33333333333333333330 modulo 3 -33333333333333333333)
  (test -3 modulo -3 -33333333333333333333)
  (test 3 remainder 3 -33333333333333333333)
  (test -3 remainder -3 -33333333333333333333)

  (test 0 modulo -2177452800 86400)
  (test 0 modulo 2177452800 -86400)
  (test 0 modulo 2177452800 86400)
  (test 0 modulo -2177452800 -86400)
  (test 0 modulo -2177452800 86400)
  (test 0 modulo 2177452800 -86400)
  (test 0 modulo 2177452800 86400)
  (test 0 modulo -2177452800 -86400)
  (test 0 modulo  0 -2177452800)
  (test #t 'remainder (tb 281474976710655 65535))
  (test #t 'remainder (tb 281474976710654 65535))
  (test #t 'remainder (tb 281474976710655325431 65535))
  (test #t 'remainder (tb 281474976710655325430 65535))

  (SECTION 6 5 8)
  (test 281474976710655 string->number "281474976710655")
  (test "281474976710655" number->string 281474976710655)
  (test 281474976710655325431 string->number "281474976710655325431")
  (test "281474976710655325431" number->string 281474976710655325431)
  (report-errs))

(define (test-numeric-predicates)
  (let* ((big-ex (expt 2 90))
	 (big-inex (exact->inexact big-ex)))
    (SECTION 6 5 5 "(bignum-inexact comparisons)")
    (test #f = (+ big-ex 1) big-inex (- big-ex 1))
    (test #f = big-inex (+ big-ex 1) (- big-ex 1))
    (test #t < (- (inexact->exact big-inex) 1)
	  big-inex
	  (+ (inexact->exact big-inex) 1))))

(SECTION 6 5 9)
(test "0" number->string 0)
(test "100" number->string 100)
(test "100" number->string 256 16)
(test 100 string->number "100")
(test 256 string->number "100" 16)
(test #f string->number "")
(test #f string->number ".")
(test #f string->number "d")
(test #f string->number "D")
(test #f string->number "i")
(test #f string->number "I")
;; The next 6 are not valid according to R5RS.
(test 3i string->number "3i")
(test 3i string->number "3I")
(test 33i string->number "33i")
(test 33i string->number "33I")
(test 3.3i string->number "3.3i")
(test 3.3i string->number "3.3I")
(test #f string->number "-")
(test #f string->number "+")
(test #t 'string->number (or (not (string->number "80000000" 16))
			     (positive? (string->number "80000000" 16))))
(test #t 'string->number (or (not (string->number "-80000000" 16))
			     (negative? (string->number "-80000000" 16))))

(SECTION 6 6)
(test #t eqv? '#\  #\Space)
(test #t eqv? #\space '#\Space)
(test #t char? #\a)
(test #t char? #\()
(test #t char? #\ )
(test #t char? '#\newline)

(test #f char=? #\A #\B)
(test #f char=? #\a #\b)
(test #f char=? #\9 #\0)
(test #t char=? #\A #\A)

(test #t char<? #\A #\B)
(test #t char<? #\a #\b)
(test #f char<? #\9 #\0)
(test #f char<? #\A #\A)

(test #f char>? #\A #\B)
(test #f char>? #\a #\b)
(test #t char>? #\9 #\0)
(test #f char>? #\A #\A)

(test #t char<=? #\A #\B)
(test #t char<=? #\a #\b)
(test #f char<=? #\9 #\0)
(test #t char<=? #\A #\A)

(test #f char>=? #\A #\B)
(test #f char>=? #\a #\b)
(test #t char>=? #\9 #\0)
(test #t char>=? #\A #\A)

(test #f char-ci=? #\A #\B)
(test #f char-ci=? #\a #\B)
(test #f char-ci=? #\A #\b)
(test #f char-ci=? #\a #\b)
(test #f char-ci=? #\9 #\0)
(test #t char-ci=? #\A #\A)
(test #t char-ci=? #\A #\a)

(test #t char-ci<? #\A #\B)
(test #t char-ci<? #\a #\B)
(test #t char-ci<? #\A #\b)
(test #t char-ci<? #\a #\b)
(test #f char-ci<? #\9 #\0)
(test #f char-ci<? #\A #\A)
(test #f char-ci<? #\A #\a)

(test #f char-ci>? #\A #\B)
(test #f char-ci>? #\a #\B)
(test #f char-ci>? #\A #\b)
(test #f char-ci>? #\a #\b)
(test #t char-ci>? #\9 #\0)
(test #f char-ci>? #\A #\A)
(test #f char-ci>? #\A #\a)

(test #t char-ci<=? #\A #\B)
(test #t char-ci<=? #\a #\B)
(test #t char-ci<=? #\A #\b)
(test #t char-ci<=? #\a #\b)
(test #f char-ci<=? #\9 #\0)
(test #t char-ci<=? #\A #\A)
(test #t char-ci<=? #\A #\a)

(test #f char-ci>=? #\A #\B)
(test #f char-ci>=? #\a #\B)
(test #f char-ci>=? #\A #\b)
(test #f char-ci>=? #\a #\b)
(test #t char-ci>=? #\9 #\0)
(test #t char-ci>=? #\A #\A)
(test #t char-ci>=? #\A #\a)

(test #t char-alphabetic? #\a)
(test #t char-alphabetic? #\A)
(test #t char-alphabetic? #\z)
(test #t char-alphabetic? #\Z)
(test #f char-alphabetic? #\0)
(test #f char-alphabetic? #\9)
(test #f char-alphabetic? #\space)
(test #f char-alphabetic? #\;)

(test #f char-numeric? #\a)
(test #f char-numeric? #\A)
(test #f char-numeric? #\z)
(test #f char-numeric? #\Z)
(test #t char-numeric? #\0)
(test #t char-numeric? #\9)
(test #f char-numeric? #\space)
(test #f char-numeric? #\;)

(test #f char-whitespace? #\a)
(test #f char-whitespace? #\A)
(test #f char-whitespace? #\z)
(test #f char-whitespace? #\Z)
(test #f char-whitespace? #\0)
(test #f char-whitespace? #\9)
(test #t char-whitespace? #\space)
(test #f char-whitespace? #\;)

(test #f char-upper-case? #\0)
(test #f char-upper-case? #\9)
(test #f char-upper-case? #\space)
(test #f char-upper-case? #\;)

(test #f char-lower-case? #\0)
(test #f char-lower-case? #\9)
(test #f char-lower-case? #\space)
(test #f char-lower-case? #\;)

(test #\. integer->char (char->integer #\.))
(test #\A integer->char (char->integer #\A))
(test #\a integer->char (char->integer #\a))
(test #\A char-upcase #\A)
(test #\A char-upcase #\a)
(test #\a char-downcase #\A)
(test #\a char-downcase #\a)
(SECTION 6 7)
(test #t string? "The word \"recursion\\\" has many meanings.")
(test #t string? "")
(define f (make-string 3 #\*))
(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
(test "abc" string #\a #\b #\c)
(test "" string)
(test 3 string-length "abc")
(test #\a string-ref "abc" 0)
(test #\c string-ref "abc" 2)
(test 0 string-length "")
(test "" substring "ab" 0 0)
(test "" substring "ab" 1 1)
(test "" substring "ab" 2 2)
(test "a" substring "ab" 0 1)
(test "b" substring "ab" 1 2)
(test "ab" substring "ab" 0 2)
(test "foobar" string-append "foo" "bar")
(test "foo" string-append "foo")
(test "foo" string-append "foo" "")
(test "foo" string-append "" "foo")
(test "" string-append)
(test "" make-string 0)
(test #t string=? "" "")
(test #f string<? "" "")
(test #f string>? "" "")
(test #t string<=? "" "")
(test #t string>=? "" "")
(test #t string-ci=? "" "")
(test #f string-ci<? "" "")
(test #f string-ci>? "" "")
(test #t string-ci<=? "" "")
(test #t string-ci>=? "" "")

(test #f string=? "A" "B")
(test #f string=? "a" "b")
(test #f string=? "9" "0")
(test #t string=? "A" "A")

(test #t string<? "A" "B")
(test #t string<? "a" "b")
(test #f string<? "9" "0")
(test #f string<? "A" "A")

(test #f string>? "A" "B")
(test #f string>? "a" "b")
(test #t string>? "9" "0")
(test #f string>? "A" "A")

(test #t string<=? "A" "B")
(test #t string<=? "a" "b")
(test #f string<=? "9" "0")
(test #t string<=? "A" "A")

(test #f string>=? "A" "B")
(test #f string>=? "a" "b")
(test #t string>=? "9" "0")
(test #t string>=? "A" "A")

(test #f string-ci=? "A" "B")
(test #f string-ci=? "a" "B")
(test #f string-ci=? "A" "b")
(test #f string-ci=? "a" "b")
(test #f string-ci=? "9" "0")
(test #t string-ci=? "A" "A")
(test #t string-ci=? "A" "a")

(test #t string-ci<? "A" "B")
(test #t string-ci<? "a" "B")
(test #t string-ci<? "A" "b")
(test #t string-ci<? "a" "b")
(test #f string-ci<? "9" "0")
(test #f string-ci<? "A" "A")
(test #f string-ci<? "A" "a")

(test #f string-ci>? "A" "B")
(test #f string-ci>? "a" "B")
(test #f string-ci>? "A" "b")
(test #f string-ci>? "a" "b")
(test #t string-ci>? "9" "0")
(test #f string-ci>? "A" "A")
(test #f string-ci>? "A" "a")

(test #t string-ci<=? "A" "B")
(test #t string-ci<=? "a" "B")
(test #t string-ci<=? "A" "b")
(test #t string-ci<=? "a" "b")
(test #f string-ci<=? "9" "0")
(test #t string-ci<=? "A" "A")
(test #t string-ci<=? "A" "a")

(test #f string-ci>=? "A" "B")
(test #f string-ci>=? "a" "B")
(test #f string-ci>=? "A" "b")
(test #f string-ci>=? "a" "b")
(test #t string-ci>=? "9" "0")
(test #t string-ci>=? "A" "A")
(test #t string-ci>=? "A" "a")
(SECTION 6 8)
(test #t vector? '#(0 (2 2 2 2) "Anna"))
(test #t vector? '#())
(test '#(a b c) vector 'a 'b 'c)
(test '#() vector)
(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
(test 0 vector-length '#())
(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
        (let ((vec (vector 0 '(2 2 2 2) "Anna")))
          (vector-set! vec 1 '("Sue" "Sue"))
          vec))
(test '#(hi hi) make-vector 2 'hi)
(test '#() make-vector 0)
(test '#() make-vector 0 'a)
(SECTION 6 9)
(test #t procedure? car)
(test #f procedure? 'car)
(test #t procedure? (lambda (x) (* x x)))
(test #f procedure? '(lambda (x) (* x x)))
(test #t call-with-current-continuation procedure?)
(test 7 apply + (list 3 4))
(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
(test 17 apply + 10 (list 3 4))
(test '() apply list '())
(define compose (lambda (f g) (lambda args (f (apply g args)))))
(test 30 (compose sqt *) 12 75)

(test '(b e h) map cadr '((a b) (d e) (g h)))
(test '(5 7 9) map + '(1 2 3) '(4 5 6))
(test '(1 2 3) map + '(1 2 3))
(test '(1 2 3) map * '(1 2 3))
(test '(-1 -2 -3) map - '(1 2 3))
(test '#(0 1 4 9 16) 'for-each
        (let ((v (make-vector 5)))
                (for-each (lambda (i) (vector-set! v i (* i i)))
                        '(0 1 2 3 4))
                v))
(test -3 call-with-current-continuation
                (lambda (exit)
                 (for-each (lambda (x) (if (negative? x) (exit x)))
                        '(54 0 37 -3 245 19))
                #t))
(define list-length
 (lambda (obj)
  (call-with-current-continuation
   (lambda (return)
    (letrec ((r (lambda (obj) (cond ((null? obj) 0)
                                ((pair? obj) (+ (r (cdr obj)) 1))
                                (else (return #f))))))
        (r obj))))))
(test 4 list-length '(1 2 3 4))
(test #f list-length '(a b . c))
(test '() map cadr '())

;;; This tests full conformance of call-with-current-continuation.  It
;;; is a separate test because some schemes do not support call/cc
;;; other than escape procedures.  I am indebted to
;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
;;; trees constructed of conses.  
(define (next-leaf-generator obj eot)
  (letrec ((return #f)
           (cont (lambda (x)
                   (recur obj)
                   (set! cont (lambda (x) (return eot)))
                   (cont #f)))
           (recur (lambda (obj)
                      (if (pair? obj)
                          (for-each recur obj)
                          (call-with-current-continuation
                           (lambda (c)
                             (set! cont c)
                             (return obj)))))))
    (lambda () (call-with-current-continuation
                (lambda (ret) (set! return ret) (cont #f))))))
(define (leaf-eq? x y)
  (let* ((eot (list 'eot))
         (xf (next-leaf-generator x eot))
         (yf (next-leaf-generator y eot)))
    (letrec ((loop (lambda (x y)
                     (cond ((not (eq? x y)) #f)
                           ((eq? eot x) #t)
                           (else (loop (xf) (yf)))))))
      (loop (xf) (yf)))))
(define (test-cont)
  (SECTION "6 9 (continuations)")
  (test #t leaf-eq? '(a (b (c))) '((a) b c))
  (test #f leaf-eq? '(a (b (c))) '((a) b c d))
  (report-errs))

;;; Test Optional R4RS DELAY syntax and FORCE procedure
(define (test-delay)
  (SECTION "6 9 (DELAY and FORCE)")
  (test 3 'delay (force (delay (+ 1 2))))
  (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
                        (list (force p) (force p))))
  (test 2 'delay (letrec ((a-stream
                           (letrec ((next (lambda (n)
                                            (cons n (delay (next (+ n 1)))))))
                             (next 0)))
                          (head car)
                          (tail (lambda (stream) (force (cdr stream)))))
                   (head (tail (tail a-stream)))))
  (letrec ((count 0)
           (p (delay (begin (set! count (+ count 1))
                            (if (> count x)
                                count
                                (force p)))))
           (x 5))
    (test 6 force p)
    (set! x 10)
    (test 6 force p))
  (test 3 'force
        (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
                 (c #f))
          (force p)))
  (report-errs))

(SECTION 6 10 1)
(test #t input-port? (current-input-port))
(test #t output-port? (current-output-port))
(test #t call-with-input-file this-file-name input-port?)
(define this-file (open-input-file this-file-name))
(test #t input-port? this-file)
(SECTION 6 10 2)
(test #\; peek-char this-file)
(test #\; read-char this-file)
(test '(TEST-INIT "scm-test" 617) read this-file)
(test #\( peek-char this-file)
(test '(define errs '()) read this-file)
(close-input-port this-file)
(close-input-port this-file)
(define (check-test-file name)
  (define test-file (open-input-file name))
  (test #t 'input-port?
        (call-with-input-file
            name
          (lambda (test-file)
            (test load-test-obj read test-file)
            (test #t eof-object? (peek-char test-file))
            (test #t eof-object? (read-char test-file))
            (input-port? test-file))))
  (test #\; read-char test-file)
  (test display-test-obj read test-file)
  (test load-test-obj read test-file)
  (close-input-port test-file))
(SECTION 6 10 3)
(define write-test-obj
  '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
(define display-test-obj
  '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
(define load-test-obj
  (list 'define 'foo (list 'quote write-test-obj)))
(test #t call-with-output-file
      "tmp1"
      (lambda (test-file)
        (write-char #\; test-file)
        (display write-test-obj test-file)
        (newline test-file)
        (write load-test-obj test-file)
        (output-port? test-file)))
(check-test-file "tmp1")

#|
(define foo (lambda () 9))
(test 9 'define (foo))
(define foo foo)
(test 9 'define (foo))
(define foo (let ((foo foo)) (lambda () (+ 1 (foo)))))
(test 10 'define (foo))
|#

(define test-file (open-output-file "tmp2"))
(write-char #\; test-file)
(display write-test-obj test-file)
(newline test-file)
(write load-test-obj test-file)
(test #t output-port? test-file)
(close-output-port test-file)
(check-test-file "tmp2")
(define (test-sc4)
  (SECTION "[scheme 4 functions]")
  (SECTION 6 7)
  (test '(#\P #\space #\l) string->list "P l")
  (test '() string->list "")
  (test "1\\\"" list->string '(#\1 #\\ #\"))
  (test "" list->string '())
  (SECTION 6 8)
  (test '(dah dah didah) vector->list '#(dah dah didah))
  (test '() vector->list '#())
  (test '#(dididit dah) list->vector '(dididit dah))
  (test '#() list->vector '())
  (SECTION 6 10 4)
  (define-variable foo "FOO")
  (load "tmp1")
  (test write-test-obj 'load foo)
  (report-errs))

(report-errs)
(let ((have-inexacts?
       (and (string->number "0.0") (inexact? (string->number "0.0"))))
      (have-bignums?
       (let ((n (string->number "281474976710655325431")))
	 (and n (exact? n)))))
  (cond (have-inexacts?
	 (test-inexact)
	 (test-inexact-printing)))
  (if have-bignums? (test-bignum))
  (if (and have-inexacts? have-bignums?)
      (test-numeric-predicates)))

;(newline)
(test-sc4)
(test-delay)
;(display "To fully test continuations:")
;(newline)
;(display "(test-cont)")
;'(newline)
(SECTION "last item in file")