test-suite/tests/r4rs.test

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