ice-9/test.scm

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