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