"Fossies" - the Fresh Open Source Software Archive

Member "scm/r4rstest.scm" (31 May 2018, 39303 Bytes) of package /linux/privat/scm-5f3.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Lisp source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "r4rstest.scm": 5f2_vs_5f3.

    1 ;;;;"r4rstest.scm":  Test R4RS correctness of scheme implementations.
    2 ;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003, 2004, 2006, 2007 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
    6 ;; published by the Free Software Foundation, either version 3 of the
    7 ;; License, or (at your option) any later version.
    8 ;;
    9 ;; This program is distributed in the hope that it will be useful, but
   10 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
   11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   12 ;; General Public License for more details.
   13 ;;
   14 ;; You should have received a copy of the GNU General Public
   15 ;; License along with this program.  If not, see
   16 ;; <http://www.gnu.org/licenses/>.
   17 
   18 ;;;;"r4rstest.scm":  Test R4RS correctness of scheme implementations.
   19 ;;; Author:          Aubrey Jaffer
   20 ;;; Home-page:       http://swiss.csail.mit.edu/~jaffer/Scheme
   21 ;;; Current version: http://swiss.csail.mit.edu/ftpdir/scm/r4rstest.scm
   22 ;;; CVS Head:
   23 ;;; http://savannah.gnu.org/cgi-bin/viewcvs/scm/scm/r4rstest.scm?rev=HEAD&only_with_tag=HEAD&content-type=text/vnd.viewcvs-markup
   24 
   25 ;;; This includes examples from
   26 ;;; William Clinger and Jonathan Rees, editors.
   27 ;;; Revised^4 Report on the Algorithmic Language Scheme
   28 ;;; and the IEEE specification.
   29 
   30 ;;; The input tests read this file expecting it to be named "r4rstest.scm".
   31 ;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
   32 ;;; these tests.  You may need to delete them in order to run
   33 ;;; "r4rstest.scm" more than once.
   34 
   35 ;;;   There are three optional tests:
   36 ;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
   37 ;;;
   38 ;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
   39 ;;;
   40 ;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
   41 ;;;   either standard.
   42 
   43 ;;; If you are testing a R3RS version which does not have `list?' do:
   44 ;;; (define list? #f)
   45 
   46 ;;; send corrections or additions to agj @ alum.mit.edu
   47 
   48 (define cur-section '())(define errs '())
   49 (define SECTION (lambda args
   50           (display "SECTION") (write args) (newline)
   51           (set! cur-section args) #t))
   52 (define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
   53 
   54 (define test
   55   (lambda (expect fun . args)
   56     (write (cons fun args))
   57     (display "  ==> ")
   58     ((lambda (res)
   59       (write res)
   60       (newline)
   61       (cond ((not (equal? expect res))
   62          (record-error (list res expect (cons fun args)))
   63          (display " BUT EXPECTED ")
   64          (write expect)
   65          (newline)
   66          #f)
   67         (else #t)))
   68      (if (procedure? fun) (apply fun args) (car args)))))
   69 (define (report-errs)
   70   (newline)
   71   (if (null? errs) (display "Passed all tests")
   72       (begin
   73     (display "errors were:")
   74     (newline)
   75     (display "(SECTION (got expected (call)))")
   76     (newline)
   77     (for-each (lambda (l) (write l) (newline))
   78           errs)))
   79   (newline))
   80 
   81 (SECTION 2 1);; test that all symbol characters are supported.
   82 '(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
   83 
   84 (SECTION 3 4)
   85 (define disjoint-type-functions
   86   (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
   87 (define type-examples
   88   (list
   89    #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
   90 (define i 1)
   91 (for-each (lambda (x) (display (make-string i #\space))
   92           (set! i (+ 3 i))
   93           (write x)
   94           (newline))
   95       disjoint-type-functions)
   96 (define type-matrix
   97   (map (lambda (x)
   98      (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
   99        (write t)
  100        (write x)
  101        (newline)
  102        t))
  103        type-examples))
  104 (set! i 0)
  105 (define j 0)
  106 (for-each (lambda (x y)
  107         (set! j (+ 1 j))
  108         (set! i 0)
  109         (for-each (lambda (f)
  110             (set! i (+ 1 i))
  111             (cond ((and (= i j))
  112                    (cond ((not (f x)) (test #t f x))))
  113                   ((f x) (test #f f x)))
  114             (cond ((and (= i j))
  115                    (cond ((not (f y)) (test #t f y))))
  116                   ((f y) (test #f f y))))
  117               disjoint-type-functions))
  118       (list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c))
  119       (list #f #\newline '() -3252 '(t . t) car "" 'nil '#()))
  120 (SECTION 4 1 2)
  121 (test '(quote a) 'quote (quote 'a))
  122 (test '(quote a) 'quote ''a)
  123 (SECTION 4 1 3)
  124 (test 12 (if #f + *) 3 4)
  125 (SECTION 4 1 4)
  126 (test 8 (lambda (x) (+ x x)) 4)
  127 (define reverse-subtract
  128   (lambda (x y) (- y x)))
  129 (test 3 reverse-subtract 7 10)
  130 (define add4
  131   (let ((x 4))
  132     (lambda (y) (+ x y))))
  133 (test 10 add4 6)
  134 (test '(3 4 5 6) (lambda x x) 3 4 5 6)
  135 (test '(5 6) (lambda (x y . z) z) 3 4 5 6)
  136 (SECTION 4 1 5)
  137 (test 'yes 'if (if (> 3 2) 'yes 'no))
  138 (test 'no 'if (if (> 2 3) 'yes 'no))
  139 (test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
  140 (SECTION 4 1 6)
  141 (define x 2)
  142 (test 3 'define (+ x 1))
  143 (set! x 4)
  144 (test 5 'set! (+ x 1))
  145 (SECTION 4 2 1)
  146 (test 'greater 'cond (cond ((> 3 2) 'greater)
  147                ((< 3 2) 'less)))
  148 (test 'equal 'cond (cond ((> 3 3) 'greater)
  149              ((< 3 3) 'less)
  150              (else 'equal)))
  151 (test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
  152              (else #f)))
  153 (test 'composite 'case (case (* 2 3)
  154              ((2 3 5 7) 'prime)
  155              ((1 4 6 8 9) 'composite)))
  156 (test 'consonant 'case (case (car '(c d))
  157              ((a e i o u) 'vowel)
  158              ((w y) 'semivowel)
  159              (else 'consonant)))
  160 (test #t 'and (and (= 2 2) (> 2 1)))
  161 (test #f 'and (and (= 2 2) (< 2 1)))
  162 (test '(f g) 'and (and 1 2 'c '(f g)))
  163 (test #t 'and (and))
  164 (test #t 'or (or (= 2 2) (> 2 1)))
  165 (test #t 'or (or (= 2 2) (< 2 1)))
  166 (test #f 'or (or #f #f #f))
  167 (test #f 'or (or))
  168 (test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
  169 (SECTION 4 2 2)
  170 (test 6 'let (let ((x 2) (y 3)) (* x y)))
  171 (test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
  172 (test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
  173 (test #t 'letrec (letrec ((even?
  174                (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
  175               (odd?
  176                (lambda (n) (if (zero? n) #f (even? (- n 1))))))
  177            (even? 88)))
  178 (define x 34)
  179 (test 5 'let (let ((x 3)) (define x 5) x))
  180 (test 34 'let x)
  181 (test 6 'let (let () (define x 6) x))
  182 (test 34 'let x)
  183 (test 34 'let (let ((x x)) x))
  184 (test 7 'let* (let* ((x 3)) (define x 7) x))
  185 (test 34 'let* x)
  186 (test 8 'let* (let* () (define x 8) x))
  187 (test 34 'let* x)
  188 (test 9 'letrec (letrec () (define x 9) x))
  189 (test 34 'letrec x)
  190 (test 10 'letrec (letrec ((x 3)) (define x 10) x))
  191 (test 34 'letrec x)
  192 (define (s x) (if x (let () (set! s x) (set! x s))))
  193 (SECTION 4 2 3)
  194 (define x 0)
  195 (test 6 'begin (begin (set! x (begin (begin 5)))
  196               (begin ((begin +) (begin x) (begin (begin 1))))))
  197 (SECTION 4 2 4)
  198 (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
  199                 (i 0 (+ i 1)))
  200                ((= i 5) vec)
  201              (vector-set! vec i i)))
  202 (test 25 'do (let ((x '(1 3 5 7 9)))
  203            (do ((x x (cdr x))
  204             (sum 0 (+ sum (car x))))
  205            ((null? x) sum))))
  206 (test 25 'do (let ((x '(1 3 5 7 9))
  207                    (sum 0))
  208            (do ((x x (cdr x)))
  209            ((null? x))
  210          (set! sum (+ sum (car x))))
  211            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 ;;From: Allegro Petrofsky <Allegro@Petrofsky.Berkeley.CA.US>
  227 (test -1 'let (let ((f -)) (let f ((n (f 1))) n)))
  228 
  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 (tprint x) #t)
  253 (test #t 'tprint (tprint 56))
  254 (define add3 (lambda (x) (+ x 3)))
  255 (test 6 'define (add3 3))
  256 (define first car)
  257 (test 1 'define (first '(1 2)))
  258 (define foo (lambda () 9))
  259 (test 9 'define (foo))
  260 (define foo foo)
  261 (test 9 'define (foo))
  262 (define foo (let ((foo foo)) (lambda () (+ 1 (foo)))))
  263 (test 10 'define (foo))
  264 (define old-+ +)
  265 (begin (begin (begin)
  266           (begin (begin (begin) (define + (lambda (x y) (list y x)))
  267                 (begin)))
  268           (begin))
  269        (begin)
  270        (begin (begin (begin) (test '(3 6) add3 6)
  271              (begin))))
  272 (set! + old-+)
  273 (test 9 add3 6)
  274 (begin)
  275 (begin (begin))
  276 (begin (begin (begin (begin))))
  277 (SECTION 5 2 2)
  278 (test 45 'define
  279       (let ((x 5))
  280     (begin (begin (begin)
  281               (begin (begin (begin) (define foo (lambda (y) (bar x y)))
  282                     (begin)))
  283               (begin))
  284            (begin)
  285            (begin)
  286            (begin (define bar (lambda (a b) (+ (* a b) a))))
  287            (begin))
  288     (begin)
  289     (begin (foo (+ x 3)))))
  290 (define x 34)
  291 (define (foo) (define x 5) x)
  292 (test 5 foo)
  293 (test 34 'define x)
  294 (define foo (lambda () (define x 5) x))
  295 (test 5 foo)
  296 (test 34 'define x)
  297 (define (foo x) ((lambda () (define x 5) x)) x)
  298 (test 88 foo 88)
  299 (test 4 foo 4)
  300 (test 34 'define x)
  301 (test 99 'internal-define (letrec ((foo (lambda (arg)
  302                       (or arg (and (procedure? foo)
  303                                (foo 99))))))
  304                 (define bar (foo #f))
  305                 (foo #f)))
  306 (test 77 'internal-define (letrec ((foo 77)
  307                    (bar #f)
  308                    (retfoo (lambda () foo)))
  309                 (define baz (retfoo))
  310                 (retfoo)))
  311 (SECTION 6 1)
  312 (test #f not #t)
  313 (test #f not 3)
  314 (test #f not (list 3))
  315 (test #t not #f)
  316 (test #f not '())
  317 (test #f not (list))
  318 (test #f not 'nil)
  319 
  320 ;(test #t boolean? #f)
  321 ;(test #f boolean? 0)
  322 ;(test #f boolean? '())
  323 (SECTION 6 2)
  324 (test #t eqv? 'a 'a)
  325 (test #f eqv? 'a 'b)
  326 (test #t eqv? 2 2)
  327 (test #t eqv? '() '())
  328 (test #t eqv? '10000 '10000)
  329 (test #f eqv? (cons 1 2)(cons 1 2))
  330 (test #f eqv? (lambda () 1) (lambda () 2))
  331 (test #f eqv? #f 'nil)
  332 (let ((p (lambda (x) x)))
  333   (test #t eqv? p p))
  334 (define gen-counter
  335  (lambda ()
  336    (let ((n 0))
  337       (lambda () (set! n (+ n 1)) n))))
  338 (let ((g (gen-counter))) (test #t eqv? g g))
  339 (test #f eqv? (gen-counter) (gen-counter))
  340 (letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
  341      (g (lambda () (if (eqv? f g) 'g 'both))))
  342   (test #f eqv? f g))
  343 
  344 (test #t eq? 'a 'a)
  345 (test #f eq? (list 'a) (list 'a))
  346 (test #t eq? '() '())
  347 (test #t eq? car car)
  348 (let ((x '(a))) (test #t eq? x x))
  349 (let ((x '#())) (test #t eq? x x))
  350 (let ((x (lambda (x) x))) (test #t eq? x x))
  351 
  352 (define test-eq?-eqv?-agreement
  353   (lambda (obj1 obj2)
  354     (cond ((eq? (eq? obj1 obj2) (eqv? obj1 obj2)))
  355       (else
  356        (record-error (list #f #t (list 'test-eq?-eqv?-agreement obj1 obj2)))
  357        (display "eqv? and eq? disagree about ")
  358        (write obj1)
  359        (display #\space)
  360        (write obj2)
  361        (newline)))))
  362 
  363 (test-eq?-eqv?-agreement '#f '#f)
  364 (test-eq?-eqv?-agreement '#t '#t)
  365 (test-eq?-eqv?-agreement '#t '#f)
  366 (test-eq?-eqv?-agreement '(a) '(a))
  367 (test-eq?-eqv?-agreement '(a) '(b))
  368 (test-eq?-eqv?-agreement car car)
  369 (test-eq?-eqv?-agreement car cdr)
  370 (test-eq?-eqv?-agreement (list 'a) (list 'a))
  371 (test-eq?-eqv?-agreement (list 'a) (list 'b))
  372 (test-eq?-eqv?-agreement '#(a) '#(a))
  373 (test-eq?-eqv?-agreement '#(a) '#(b))
  374 (test-eq?-eqv?-agreement "abc" "abc")
  375 (test-eq?-eqv?-agreement "abc" "abz")
  376 
  377 (test #t equal? 'a 'a)
  378 (test #t equal? '(a) '(a))
  379 (test #t equal? '(a (b) c) '(a (b) c))
  380 (test #t equal? "abc" "abc")
  381 (test #t equal? 2 2)
  382 (test #t equal? (make-vector 5 'a) (make-vector 5 'a))
  383 (SECTION 6 3)
  384 (test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
  385 (define x (list 'a 'b 'c))
  386 (define y x)
  387 (and list? (test #t list? y))
  388 (set-cdr! x 4)
  389 (test '(a . 4) 'set-cdr! x)
  390 (test #t eqv? x y)
  391 (test '(a b c . d) 'dot '(a . (b . (c . d))))
  392 (and list? (test #f list? y))
  393 (and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
  394 
  395 ;(test #t pair? '(a . b))
  396 ;(test #t pair? '(a . 1))
  397 ;(test #t pair? '(a b c))
  398 ;(test #f pair? '())
  399 ;(test #f pair? '#(a b))
  400 
  401 (test '(a) cons 'a '())
  402 (test '((a) b c d) cons '(a) '(b c d))
  403 (test '("a" b c) cons "a" '(b c))
  404 (test '(a . 3) cons 'a 3)
  405 (test '((a b) . c) cons '(a b) 'c)
  406 
  407 (test 'a car '(a b c))
  408 (test '(a) car '((a) b c d))
  409 (test 1 car '(1 . 2))
  410 
  411 (test '(b c d) cdr '((a) b c d))
  412 (test 2 cdr '(1 . 2))
  413 
  414 (test '(a 7 c) list 'a (+ 3 4) 'c)
  415 (test '() list)
  416 
  417 (test 3 length '(a b c))
  418 (test 3 length '(a (b) (c d e)))
  419 (test 0 length '())
  420 
  421 (test '(x y) append '(x) '(y))
  422 (test '(a b c d) append '(a) '(b c d))
  423 (test '(a (b) (c)) append '(a (b)) '((c)))
  424 (test '() append)
  425 (test '(a b c . d) append '(a b) '(c . d))
  426 (test 'a append '() 'a)
  427 
  428 (test '(c b a) reverse '(a b c))
  429 (test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
  430 
  431 (test 'c list-ref '(a b c d) 2)
  432 
  433 (test '(a b c) memq 'a '(a b c))
  434 (test '(b c) memq 'b '(a b c))
  435 (test '#f memq 'a '(b c d))
  436 (test '#f memq (list 'a) '(b (a) c))
  437 (test '((a) c) member (list 'a) '(b (a) c))
  438 (test '(101 102) memv 101 '(100 101 102))
  439 
  440 (define e '((a 1) (b 2) (c 3)))
  441 (test '(a 1) assq 'a e)
  442 (test '(b 2) assq 'b e)
  443 (test #f assq 'd e)
  444 (test #f assq (list 'a) '(((a)) ((b)) ((c))))
  445 (test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
  446 (test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
  447 (SECTION 6 4)
  448 ;(test #t symbol? 'foo)
  449 (test #t symbol? (car '(a b)))
  450 ;(test #f symbol? "bar")
  451 ;(test #t symbol? 'nil)
  452 ;(test #f symbol? '())
  453 ;(test #f symbol? #f)
  454 ;;; But first, what case are symbols in?  Determine the standard case:
  455 (define char-standard-case char-upcase)
  456 (if (string=? (symbol->string 'A) "a")
  457     (set! char-standard-case char-downcase))
  458 (test #t 'standard-case
  459       (string=? (symbol->string 'a) (symbol->string 'A)))
  460 (test #t 'standard-case
  461       (or (string=? (symbol->string 'a) "A")
  462       (string=? (symbol->string 'A) "a")))
  463 (define (str-copy s)
  464   (let ((v (make-string (string-length s))))
  465     (do ((i (- (string-length v) 1) (- i 1)))
  466     ((< i 0) v)
  467       (string-set! v i (string-ref s i)))))
  468 (define (string-standard-case s)
  469   (set! s (str-copy s))
  470   (do ((i 0 (+ 1 i))
  471        (sl (string-length s)))
  472       ((>= i sl) s)
  473       (string-set! s i (char-standard-case (string-ref s i)))))
  474 (test (string-standard-case "flying-fish") symbol->string 'flying-fish)
  475 (test (string-standard-case "martin") symbol->string 'Martin)
  476 (test "Malvina" symbol->string (string->symbol "Malvina"))
  477 (test #t 'standard-case (eq? 'a 'A))
  478 
  479 (define x (string #\a #\b))
  480 (define y (string->symbol x))
  481 (string-set! x 0 #\c)
  482 (test "cb" 'string-set! x)
  483 (test "ab" symbol->string y)
  484 (test y string->symbol "ab")
  485 
  486 (test #t eq? 'mISSISSIppi 'mississippi)
  487 (test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
  488 (test 'JollyWog string->symbol (symbol->string 'JollyWog))
  489 
  490 (SECTION 6 5 5)
  491 (test #t number? 3)
  492 (test #t complex? 3)
  493 (test #t real? 3)
  494 (test #t rational? 3)
  495 (test #t integer? 3)
  496 
  497 (test #t exact? 3)
  498 (test #f inexact? 3)
  499 
  500 (test 1 expt 0 0)
  501 (test 0 expt 0 1)
  502 (test 0 expt 0 256)
  503 ;;(test 0 expt 0 -255)
  504 (test 1 expt -1 256)
  505 (test -1 expt -1 255)
  506 (test 1 expt -1 -256)
  507 (test -1 expt -1 -255)
  508 (test 1 expt 256 0)
  509 (test 1 expt -256 0)
  510 (test 256 expt 256 1)
  511 (test -256 expt -256 1)
  512 (test 8 expt 2 3)
  513 (test -8 expt -2 3)
  514 (test 9 expt 3 2)
  515 (test 9 expt -3 2)
  516 
  517 (test #t = 22 22 22)
  518 (test #t = 22 22)
  519 (test #f = 34 34 35)
  520 (test #f = 34 35)
  521 (test #t > 3 -6246)
  522 (test #f > 9 9 -2424)
  523 (test #t >= 3 -4 -6246)
  524 (test #t >= 9 9)
  525 (test #f >= 8 9)
  526 (test #t < -1 2 3 4 5 6 7 8)
  527 (test #f < -1 2 3 4 4 5 6 7)
  528 (test #t <= -1 2 3 4 5 6 7 8)
  529 (test #t <= -1 2 3 4 4 5 6 7)
  530 (test #f < 1 3 2)
  531 (test #f >= 1 3 2)
  532 
  533 (test #t zero? 0)
  534 (test #f zero? 1)
  535 (test #f zero? -1)
  536 (test #f zero? -100)
  537 (test #t positive? 4)
  538 (test #f positive? -4)
  539 (test #f positive? 0)
  540 (test #f negative? 4)
  541 (test #t negative? -4)
  542 (test #f negative? 0)
  543 (test #t odd? 3)
  544 (test #f odd? 2)
  545 (test #f odd? -4)
  546 (test #t odd? -1)
  547 (test #f even? 3)
  548 (test #t even? 2)
  549 (test #t even? -4)
  550 (test #f even? -1)
  551 
  552 (test 38 max 34 5 7 38 6)
  553 (test -24 min 3  5 5 330 4 -24)
  554 
  555 (test 7 + 3 4)
  556 (test '3 + 3)
  557 (test 0 +)
  558 (test 4 * 4)
  559 (test 1 *)
  560 (test 1 / 1)
  561 (test -1 / -1)
  562 (test 2 / 6 3)
  563 (test -3 / 6 -2)
  564 (test -3 / -6 2)
  565 (test 3 / -6 -2)
  566 (test -1 - 3 4)
  567 (test -3 - 3)
  568 (test 7 abs -7)
  569 (test 7 abs 7)
  570 (test 0 abs 0)
  571 
  572 (test 5 quotient 35 7)
  573 (test -5 quotient -35 7)
  574 (test -5 quotient 35 -7)
  575 (test 5 quotient -35 -7)
  576 (test 1 modulo 13 4)
  577 (test 1 remainder 13 4)
  578 (test 3 modulo -13 4)
  579 (test -1 remainder -13 4)
  580 (test -3 modulo 13 -4)
  581 (test 1 remainder 13 -4)
  582 (test -1 modulo -13 -4)
  583 (test -1 remainder -13 -4)
  584 (test 0 modulo 0 86400)
  585 (test 0 modulo 0 -86400)
  586 (define (divtest n1 n2)
  587     (= n1 (+ (* n2 (quotient n1 n2))
  588          (remainder n1 n2))))
  589 (test #t divtest 238 9)
  590 (test #t divtest -238 9)
  591 (test #t divtest 238 -9)
  592 (test #t divtest -238 -9)
  593 
  594 (test 4 gcd 0 4)
  595 (test 4 gcd -4 0)
  596 (test 4 gcd 32 -36)
  597 (test 0 gcd)
  598 (test 288 lcm 32 -36)
  599 (test 1 lcm)
  600 
  601 (SECTION 6 5 5)
  602 ;;; Implementations which don't allow division by 0 can have fragile
  603 ;;; string->number.
  604 (define (test-string->number str)
  605   (define ans (string->number str))
  606   (cond ((not ans) #t) ((number? ans) #t) (else ans)))
  607 (for-each (lambda (str) (test #t test-string->number str))
  608       '("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0"
  609         "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i"
  610         "#i" "#e" "#" "#i0/0"))
  611 (cond ((number? (string->number "1+1i")) ;More kawa bait
  612        (test #t number? (string->number "#i-i"))
  613        (test #t number? (string->number "#i+i"))
  614        (test #t number? (string->number "#i2+i"))))
  615 
  616 ;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
  617 ;;; Modified by jaffer.
  618 (define (test-inexact)
  619   (define f3.9 (string->number "3.9"))
  620   (define f4.0 (string->number "4.0"))
  621   (define f-3.25 (string->number "-3.25"))
  622   (define f.25 (string->number ".25"))
  623   (define f4.5 (string->number "4.5"))
  624   (define f3.5 (string->number "3.5"))
  625   (define f0.0 (string->number "0.0"))
  626   (define f0.8 (string->number "0.8"))
  627   (define f1.0 (string->number "1.0"))
  628   (define f1e300 (and (string->number "1+3i") (string->number "1e300")))
  629   (define f1e-300 (and (string->number "1+3i") (string->number "1e-300")))
  630   (define wto write-test-obj)
  631   (define lto load-test-obj)
  632   (newline)
  633   (display ";testing inexact numbers; ")
  634   (newline)
  635   (SECTION 6 2)
  636   (test #f eqv? 1 f1.0)
  637   (test #f eqv? 0 f0.0)
  638   (test #t eqv? f0.0 f0.0)
  639   (cond ((= f0.0 (- f0.0))
  640      (test #t eqv? f0.0 (- f0.0))
  641      (test #t equal? f0.0 (- f0.0))))
  642   (cond ((= f0.0 (* -5 f0.0))
  643      (test #t eqv? f0.0 (* -5 f0.0))
  644      (test #t equal? f0.0 (* -5 f0.0))))
  645   (SECTION 6 5 5)
  646   (and f1e300
  647        (let ((f1e300+1e300i (make-rectangular f1e300 f1e300)))
  648      (test f1.0 'magnitude (/ (magnitude f1e300+1e300i)
  649                   (* f1e300 (sqrt 2))))
  650      (test f.25 / f1e300+1e300i (* 4 f1e300+1e300i))))
  651   (and f1e-300
  652        (let ((f1e-300+1e-300i (make-rectangular f1e-300 f1e-300)))
  653      (test f1.0 'magnitude (round (/ (magnitude f1e-300+1e-300i)
  654                      (* f1e-300 (sqrt 2)))))
  655      (test f.25 / f1e-300+1e-300i (* 4 f1e-300+1e-300i))))
  656   (test #t = f0.0 f0.0)
  657   (test #t = f0.0 (- f0.0))
  658   (test #t = f0.0 (* -5 f0.0))
  659   (test #t inexact? f3.9)
  660   (test #t 'max (inexact? (max f3.9 4)))
  661   (test f4.0 max f3.9 4)
  662   (test f4.0 exact->inexact 4)
  663   (test f4.0 exact->inexact f4.0)
  664   (test 4 inexact->exact 4)
  665   (test 4 inexact->exact f4.0)
  666   (test (- f4.0) round (- f4.5))
  667   (test (- f4.0) round (- f3.5))
  668   (test (- f4.0) round (- f3.9))
  669   (test f0.0 round f0.0)
  670   (test f0.0 round f.25)
  671   (test f1.0 round f0.8)
  672   (test f4.0 round f3.5)
  673   (test f4.0 round f4.5)
  674 
  675   ;;(test f1.0 expt f0.0 f0.0)
  676   ;;(test f1.0 expt f0.0 0)
  677   ;;(test f1.0 expt 0    f0.0)
  678   (test f0.0 expt f0.0 f1.0)
  679   (test f0.0 expt f0.0 1)
  680   (test f0.0 expt 0    f1.0)
  681   (test f1.0 expt -25  f0.0)
  682   (test f1.0 expt f-3.25 f0.0)
  683   (test f1.0 expt f-3.25 0)
  684   ;;(test f0.0 expt f0.0 f-3.25)
  685 
  686   (test (atan 1) atan 1 1)
  687   (set! write-test-obj (list f.25 f-3.25)) ;.25 inexact errors less likely.
  688   (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
  689   (test #t call-with-output-file
  690     "tmp3"
  691     (lambda (test-file)
  692       (write-char #\; test-file)
  693       (display #\; test-file)
  694       (display ";" test-file)
  695       (write write-test-obj test-file)
  696       (newline test-file)
  697       (write load-test-obj test-file)
  698       (output-port? test-file)))
  699   (check-test-file "tmp3")
  700   (set! write-test-obj wto)
  701   (set! load-test-obj lto)
  702   (let ((x (string->number "4195835.0"))
  703     (y (string->number "3145727.0")))
  704     (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
  705   (report-errs))
  706 
  707 (define (test-inexact-printing)
  708   (let ((f0.0 (string->number "0.0"))
  709     (f0.5 (string->number "0.5"))
  710     (f1.0 (string->number "1.0"))
  711     (f2.0 (string->number "2.0")))
  712     (define log2
  713       (let ((l2 (log 2)))
  714     (lambda (x) (/ (log x) l2))))
  715 
  716     (define (slow-frexp x)
  717       (if (zero? x)
  718       (list f0.0 0)
  719       (let* ((l2 (log2 x))
  720          (e (floor (log2 x)))
  721          (e (if (= l2 e)
  722             (inexact->exact e)
  723             (+ (inexact->exact e) 1)))
  724          (f (/ x (expt 2 e))))
  725         (list f e))))
  726 
  727     (define float-precision
  728       (let ((mantissa-bits
  729          (do ((i 0 (+ i 1))
  730           (eps f1.0 (* f0.5 eps)))
  731          ((= f1.0 (+ f1.0 eps))
  732           i)))
  733         (minval
  734          (do ((x f1.0 (* f0.5 x)))
  735          ((zero? (* f0.5 x)) x))))
  736     (lambda (x)
  737       (apply (lambda (f e)
  738            (let ((eps
  739               (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits))))
  740                 ((zero? f) minval)
  741                 (else (expt f2.0 (- e mantissa-bits))))))
  742              (if (zero? eps)    ;Happens if gradual underflow.
  743              minval
  744              eps)))
  745          (slow-frexp x)))))
  746 
  747     (define (float-print-test x)
  748       (define (testit number)
  749     (eqv? number (string->number (number->string number))))
  750       (let ((eps (float-precision x))
  751         (all-ok? #t))
  752     (do ((j -100 (+ j 1)))
  753         ((or (not all-ok?) (> j 100)) all-ok?)
  754       (let* ((xx (+ x (* j eps)))
  755          (ok? (testit xx)))
  756         (cond ((not ok?)
  757            (display "Number readback failure for ")
  758            (display `(+ ,x (* ,j ,eps))) (newline)
  759            (display xx) (newline)
  760            (display (string->number (number->string xx))) (newline)
  761            (set! all-ok? #f))
  762           ;;   (else (display xx) (newline))
  763           )))))
  764 
  765     (define (mult-float-print-test x)
  766       (let ((res #t))
  767     (for-each
  768      (lambda (mult)
  769        (or (float-print-test (* mult x)) (set! res #f)))
  770      (map string->number
  771           '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100"
  772         "0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100")))
  773     res))
  774 
  775     (define (float-rw-range-test)
  776       (define success #t)
  777       (do ((cnt -323 (+ 1 cnt)))
  778       ((> cnt 308) success)
  779     (let* ((estr (string-append "1.e" (number->string cnt)))
  780            (num (string->number estr))
  781            (str (number->string num)))
  782       (cond ((or (>= (string-length str) 10)
  783              (not (equal? (string->number str) num)))
  784          (set! success #f)
  785          (for-each write (list estr num str (string->number str))))))))
  786 
  787     (define (float-powers-of-2-test)
  788       (define all-ok? #t)
  789       (do ((xx (expt f2.0 1000) (/ xx 2))
  790        (p 1000 (+ p -1)))
  791       ((zero? xx) all-ok?)
  792     (let ((cnv (string->number (number->string xx))))
  793       (cond ((not (= xx cnv))
  794          (display "Number readback failure for ")
  795          (display `(expt ,f2.0 ,p)) (newline)
  796          (display xx) (newline)
  797          (set! all-ok? #f))))))
  798 
  799     (SECTION 6 5 6)
  800     (test #t 'float-print-test (float-print-test f0.0))
  801     (test #t 'mult-float-print-test (mult-float-print-test f1.0))
  802     (test #t 'mult-float-print-test (mult-float-print-test
  803                      (string->number "3.0")))
  804     (test #t 'mult-float-print-test (mult-float-print-test
  805                      (string->number "7.0")))
  806     (test #t 'mult-float-print-test (mult-float-print-test
  807                      (string->number "3.1415926535897931")))
  808     (test #t 'mult-float-print-test (mult-float-print-test
  809                      (string->number "2.7182818284590451")))
  810     (test #t float-rw-range-test)
  811     (test #t float-powers-of-2-test)))
  812 
  813 (define (test-bignum)
  814   (define tb
  815     (lambda (n1 n2)
  816       (= n1 (+ (* n2 (quotient n1 n2))
  817            (remainder n1 n2)))))
  818   (define b3-3 (string->number "33333333333333333333"))
  819   (define b3-2 (string->number "33333333333333333332"))
  820   (define b3-0 (string->number "33333333333333333330"))
  821   (define b1-1 (string->number "11111111111111111111"))
  822   (define b2-0 (string->number "2177452800"))
  823   (newline)
  824   (display ";testing bignums; ")
  825   (newline)
  826   (SECTION 6 5 7)
  827   (test 0 modulo b3-3 3)
  828   (test 0 modulo b3-3 -3)
  829   (test 0 remainder b3-3 3)
  830   (test 0 remainder b3-3 -3)
  831   (test 2 modulo b3-2 3)
  832   (test -1 modulo b3-2 -3)
  833   (test 2 remainder b3-2 3)
  834   (test 2 remainder b3-2 -3)
  835   (test 1 modulo (- b3-2) 3)
  836   (test -2 modulo (- b3-2) -3)
  837   (test -2 remainder (- b3-2) 3)
  838   (test -2 remainder (- b3-2) -3)
  839 
  840   (test 3 modulo 3 b3-3)
  841   (test b3-0 modulo -3 b3-3)
  842   (test 3 remainder 3 b3-3)
  843   (test -3 remainder -3 b3-3)
  844   (test (- b3-0) modulo 3 (- b3-3))
  845   (test -3 modulo -3 (- b3-3))
  846   (test 3 remainder 3 (- b3-3))
  847   (test -3 remainder -3 (- b3-3))
  848 
  849   (test 0 modulo (- b2-0) 86400)
  850   (test 0 modulo b2-0 -86400)
  851   (test 0 modulo b2-0 86400)
  852   (test 0 modulo (- b2-0) -86400)
  853   (test 0 modulo  0 (- b2-0))
  854   (test #t 'remainder (tb (string->number "281474976710655325431") 65535))
  855   (test #t 'remainder (tb (string->number "281474976710655325430") 65535))
  856 
  857   (test b1-1 gcd b3-3 b1-1)
  858   (test 1 gcd b3-2 b1-1)
  859   (test 1 gcd b3-0 b1-1)
  860   (test 3 gcd b3-3 b3-0)
  861 
  862   (test b3-3 lcm b3-3 b1-1)
  863   (test b3-3 lcm -3 b1-1)
  864 
  865   (let ((n (string->number
  866         "30414093201713378043612608166064768844377641568960512")))
  867     (and n (exact? n)
  868      (do ((pow3 1 (* 3 pow3))
  869           (cnt 21 (+ -1 cnt)))
  870          ((negative? cnt)
  871           (zero? (modulo n pow3))))))
  872 
  873   (SECTION 6 5 8)
  874   (test "281474976710655325431" number->string
  875     (string->number "281474976710655325431"))
  876   (report-errs))
  877 
  878 (define (test-numeric-predicates)
  879   (let* ((big-ex (expt 2 150))
  880      (big-inex (exact->inexact big-ex)))
  881     (newline)
  882     (display ";testing bignum-inexact comparisons;")
  883     (newline)
  884     (SECTION 6 5 5)
  885     (test #f = (+ big-ex 1) big-inex (- big-ex 1))
  886     (test #f = big-inex (+ big-ex 1) (- big-ex 1))
  887     (test #t < (- (inexact->exact big-inex) 1)
  888       big-inex
  889       (+ (inexact->exact big-inex) 1))))
  890 
  891 
  892 (SECTION 6 5 9)
  893 (test "0" number->string 0)
  894 (test "100" number->string 100)
  895 (test "100" number->string 256 16)
  896 (test 100 string->number "100")
  897 (test 256 string->number "100" 16)
  898 (test #f string->number "")
  899 (test #f string->number ".")
  900 (test #f string->number "d")
  901 (test #f string->number "D")
  902 (test #f string->number "i")
  903 (test #f string->number "I")
  904 (test #f string->number "3i")
  905 (test #f string->number "3I")
  906 (test #f string->number "33i")
  907 (test #f string->number "33I")
  908 (test #f string->number "3.3i")
  909 (test #f string->number "3.3I")
  910 (test #f string->number "-")
  911 (test #f string->number "+")
  912 (test #t 'string->number (or (not (string->number "80000000" 16))
  913                  (positive? (string->number "80000000" 16))))
  914 (test #t 'string->number (or (not (string->number "-80000000" 16))
  915                  (negative? (string->number "-80000000" 16))))
  916 
  917 (SECTION 6 6)
  918 (test #t eqv? '#\  #\Space)
  919 (test #t eqv? #\space '#\Space)
  920 (test #t char? #\a)
  921 (test #t char? #\()
  922 (test #t char? #\space)
  923 (test #t char? '#\newline)
  924 
  925 (test #f char=? #\A #\B)
  926 (test #f char=? #\a #\b)
  927 (test #f char=? #\9 #\0)
  928 (test #t char=? #\A #\A)
  929 
  930 (test #t char<? #\A #\B)
  931 (test #t char<? #\a #\b)
  932 (test #f char<? #\9 #\0)
  933 (test #f char<? #\A #\A)
  934 
  935 (test #f char>? #\A #\B)
  936 (test #f char>? #\a #\b)
  937 (test #t char>? #\9 #\0)
  938 (test #f char>? #\A #\A)
  939 
  940 (test #t char<=? #\A #\B)
  941 (test #t char<=? #\a #\b)
  942 (test #f char<=? #\9 #\0)
  943 (test #t char<=? #\A #\A)
  944 
  945 (test #f char>=? #\A #\B)
  946 (test #f char>=? #\a #\b)
  947 (test #t char>=? #\9 #\0)
  948 (test #t char>=? #\A #\A)
  949 
  950 (test #f char-ci=? #\A #\B)
  951 (test #f char-ci=? #\a #\B)
  952 (test #f char-ci=? #\A #\b)
  953 (test #f char-ci=? #\a #\b)
  954 (test #f char-ci=? #\9 #\0)
  955 (test #t char-ci=? #\A #\A)
  956 (test #t char-ci=? #\A #\a)
  957 
  958 (test #t char-ci<? #\A #\B)
  959 (test #t char-ci<? #\a #\B)
  960 (test #t char-ci<? #\A #\b)
  961 (test #t char-ci<? #\a #\b)
  962 (test #f char-ci<? #\9 #\0)
  963 (test #f char-ci<? #\A #\A)
  964 (test #f char-ci<? #\A #\a)
  965 
  966 (test #f char-ci>? #\A #\B)
  967 (test #f char-ci>? #\a #\B)
  968 (test #f char-ci>? #\A #\b)
  969 (test #f char-ci>? #\a #\b)
  970 (test #t char-ci>? #\9 #\0)
  971 (test #f char-ci>? #\A #\A)
  972 (test #f char-ci>? #\A #\a)
  973 
  974 (test #t char-ci<=? #\A #\B)
  975 (test #t char-ci<=? #\a #\B)
  976 (test #t char-ci<=? #\A #\b)
  977 (test #t char-ci<=? #\a #\b)
  978 (test #f char-ci<=? #\9 #\0)
  979 (test #t char-ci<=? #\A #\A)
  980 (test #t char-ci<=? #\A #\a)
  981 
  982 (test #f char-ci>=? #\A #\B)
  983 (test #f char-ci>=? #\a #\B)
  984 (test #f char-ci>=? #\A #\b)
  985 (test #f char-ci>=? #\a #\b)
  986 (test #t char-ci>=? #\9 #\0)
  987 (test #t char-ci>=? #\A #\A)
  988 (test #t char-ci>=? #\A #\a)
  989 
  990 (test #t char-alphabetic? #\a)
  991 (test #t char-alphabetic? #\A)
  992 (test #t char-alphabetic? #\z)
  993 (test #t char-alphabetic? #\Z)
  994 (test #f char-alphabetic? #\0)
  995 (test #f char-alphabetic? #\9)
  996 (test #f char-alphabetic? #\space)
  997 (test #f char-alphabetic? #\;)
  998 
  999 (test #f char-numeric? #\a)
 1000 (test #f char-numeric? #\A)
 1001 (test #f char-numeric? #\z)
 1002 (test #f char-numeric? #\Z)
 1003 (test #t char-numeric? #\0)
 1004 (test #t char-numeric? #\9)
 1005 (test #f char-numeric? #\space)
 1006 (test #f char-numeric? #\;)
 1007 
 1008 (test #f char-whitespace? #\a)
 1009 (test #f char-whitespace? #\A)
 1010 (test #f char-whitespace? #\z)
 1011 (test #f char-whitespace? #\Z)
 1012 (test #f char-whitespace? #\0)
 1013 (test #f char-whitespace? #\9)
 1014 (test #t char-whitespace? #\space)
 1015 (test #f char-whitespace? #\;)
 1016 
 1017 (test #f char-upper-case? #\0)
 1018 (test #f char-upper-case? #\9)
 1019 (test #f char-upper-case? #\space)
 1020 (test #f char-upper-case? #\;)
 1021 
 1022 (test #f char-lower-case? #\0)
 1023 (test #f char-lower-case? #\9)
 1024 (test #f char-lower-case? #\space)
 1025 (test #f char-lower-case? #\;)
 1026 
 1027 (test #\. integer->char (char->integer #\.))
 1028 (test #\A integer->char (char->integer #\A))
 1029 (test #\a integer->char (char->integer #\a))
 1030 (test #\A char-upcase #\A)
 1031 (test #\A char-upcase #\a)
 1032 (test #\a char-downcase #\A)
 1033 (test #\a char-downcase #\a)
 1034 (SECTION 6 7)
 1035 (test #t string? "The word \"recursion\\\" has many meanings.")
 1036 ;(test #t string? "")
 1037 (define f (make-string 3 #\*))
 1038 (test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
 1039 (test "abc" string #\a #\b #\c)
 1040 (test "" string)
 1041 (test 3 string-length "abc")
 1042 (test #\a string-ref "abc" 0)
 1043 (test #\c string-ref "abc" 2)
 1044 (test 0 string-length "")
 1045 (test "" substring "ab" 0 0)
 1046 (test "" substring "ab" 1 1)
 1047 (test "" substring "ab" 2 2)
 1048 (test "a" substring "ab" 0 1)
 1049 (test "b" substring "ab" 1 2)
 1050 (test "ab" substring "ab" 0 2)
 1051 (test "foobar" string-append "foo" "bar")
 1052 (test "foo" string-append "foo")
 1053 (test "foo" string-append "foo" "")
 1054 (test "foo" string-append "" "foo")
 1055 (test "" string-append)
 1056 (test "" make-string 0)
 1057 (test #t string=? "" "")
 1058 (test #f string<? "" "")
 1059 (test #f string>? "" "")
 1060 (test #t string<=? "" "")
 1061 (test #t string>=? "" "")
 1062 (test #t string-ci=? "" "")
 1063 (test #f string-ci<? "" "")
 1064 (test #f string-ci>? "" "")
 1065 (test #t string-ci<=? "" "")
 1066 (test #t string-ci>=? "" "")
 1067 
 1068 (test #f string=? "A" "B")
 1069 (test #f string=? "a" "b")
 1070 (test #f string=? "9" "0")
 1071 (test #t string=? "A" "A")
 1072 
 1073 (test #t string<? "A" "B")
 1074 (test #t string<? "a" "b")
 1075 (test #f string<? "9" "0")
 1076 (test #f string<? "A" "A")
 1077 
 1078 (test #f string>? "A" "B")
 1079 (test #f string>? "a" "b")
 1080 (test #t string>? "9" "0")
 1081 (test #f string>? "A" "A")
 1082 
 1083 (test #t string<=? "A" "B")
 1084 (test #t string<=? "a" "b")
 1085 (test #f string<=? "9" "0")
 1086 (test #t string<=? "A" "A")
 1087 
 1088 (test #f string>=? "A" "B")
 1089 (test #f string>=? "a" "b")
 1090 (test #t string>=? "9" "0")
 1091 (test #t string>=? "A" "A")
 1092 
 1093 (test #f string-ci=? "A" "B")
 1094 (test #f string-ci=? "a" "B")
 1095 (test #f string-ci=? "A" "b")
 1096 (test #f string-ci=? "a" "b")
 1097 (test #f string-ci=? "9" "0")
 1098 (test #t string-ci=? "A" "A")
 1099 (test #t string-ci=? "A" "a")
 1100 
 1101 (test #t string-ci<? "A" "B")
 1102 (test #t string-ci<? "a" "B")
 1103 (test #t string-ci<? "A" "b")
 1104 (test #t string-ci<? "a" "b")
 1105 (test #f string-ci<? "9" "0")
 1106 (test #f string-ci<? "A" "A")
 1107 (test #f string-ci<? "A" "a")
 1108 
 1109 (test #f string-ci>? "A" "B")
 1110 (test #f string-ci>? "a" "B")
 1111 (test #f string-ci>? "A" "b")
 1112 (test #f string-ci>? "a" "b")
 1113 (test #t string-ci>? "9" "0")
 1114 (test #f string-ci>? "A" "A")
 1115 (test #f string-ci>? "A" "a")
 1116 
 1117 (test #t string-ci<=? "A" "B")
 1118 (test #t string-ci<=? "a" "B")
 1119 (test #t string-ci<=? "A" "b")
 1120 (test #t string-ci<=? "a" "b")
 1121 (test #f string-ci<=? "9" "0")
 1122 (test #t string-ci<=? "A" "A")
 1123 (test #t string-ci<=? "A" "a")
 1124 
 1125 (test #f string-ci>=? "A" "B")
 1126 (test #f string-ci>=? "a" "B")
 1127 (test #f string-ci>=? "A" "b")
 1128 (test #f string-ci>=? "a" "b")
 1129 (test #t string-ci>=? "9" "0")
 1130 (test #t string-ci>=? "A" "A")
 1131 (test #t string-ci>=? "A" "a")
 1132 (SECTION 6 8)
 1133 (test #t vector? '#(0 (2 2 2 2) "Anna"))
 1134 ;(test #t vector? '#())
 1135 (test '#(a b c) vector 'a 'b 'c)
 1136 (test '#() vector)
 1137 (test 3 vector-length '#(0 (2 2 2 2) "Anna"))
 1138 (test 0 vector-length '#())
 1139 (test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
 1140 (test '#(0 ("Sue" "Sue") "Anna") 'vector-set
 1141     (let ((vec (vector 0 '(2 2 2 2) "Anna")))
 1142       (vector-set! vec 1 '("Sue" "Sue"))
 1143       vec))
 1144 (test '#(hi hi) make-vector 2 'hi)
 1145 (test '#() make-vector 0)
 1146 (test '#() make-vector 0 'a)
 1147 (SECTION 6 9)
 1148 (test #t procedure? car)
 1149 (test #f procedure? 'car)
 1150 (test #t procedure? (lambda (x) (* x x)))
 1151 (test #f procedure? '(lambda (x) (* x x)))
 1152 (test #t call-with-current-continuation procedure?)
 1153 (test #t procedure? /)
 1154 (test 7 apply + (list 3 4))
 1155 (test 7 apply (lambda (a b) (+ a b)) (list 3 4))
 1156 (test 17 apply + 10 (list 3 4))
 1157 (test '() apply list '())
 1158 (define compose (lambda (f g) (lambda args (f (apply g args)))))
 1159 (test 30 (compose sqt *) 12 75)
 1160 
 1161 (test '(b e h) map cadr '((a b) (d e) (g h)))
 1162 (test '(5 7 9) map + '(1 2 3) '(4 5 6))
 1163 (test '(1 2 3) map + '(1 2 3))
 1164 (test '(1 2 3) map * '(1 2 3))
 1165 (test '(-1 -2 -3) map - '(1 2 3))
 1166 (test '#(0 1 4 9 16) 'for-each
 1167       (let ((v (make-vector 5)))
 1168     (for-each (lambda (i) (vector-set! v i (* i i)))
 1169           '(0 1 2 3 4))
 1170     v))
 1171 (test -3 call-with-current-continuation
 1172       (lambda (exit)
 1173     (for-each (lambda (x) (if (negative? x) (exit x)))
 1174           '(54 0 37 -3 245 19))
 1175     #t))
 1176 (define list-length
 1177  (lambda (obj)
 1178   (call-with-current-continuation
 1179    (lambda (return)
 1180     (letrec ((r (lambda (obj) (cond ((null? obj) 0)
 1181                 ((pair? obj) (+ (r (cdr obj)) 1))
 1182                 (else (return #f))))))
 1183     (r obj))))))
 1184 (test 4 list-length '(1 2 3 4))
 1185 (test #f list-length '(a b . c))
 1186 (test '() map cadr '())
 1187 
 1188 ;;; This tests full conformance of call-with-current-continuation.  It
 1189 ;;; is a separate test because some schemes do not support call/cc
 1190 ;;; other than escape procedures.  I am indebted to
 1191 ;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
 1192 ;;; code.  The function leaf-eq? compares the leaves of 2 arbitrary
 1193 ;;; trees constructed of conses.
 1194 (define (next-leaf-generator obj eot)
 1195   (letrec ((return #f)
 1196        (cont (lambda (x)
 1197            (recur obj)
 1198            (set! cont (lambda (x) (return eot)))
 1199            (cont #f)))
 1200        (recur (lambda (obj)
 1201               (if (pair? obj)
 1202               (for-each recur obj)
 1203               (call-with-current-continuation
 1204                (lambda (c)
 1205                  (set! cont c)
 1206                  (return obj)))))))
 1207     (lambda () (call-with-current-continuation
 1208         (lambda (ret) (set! return ret) (cont #f))))))
 1209 (define (leaf-eq? x y)
 1210   (let* ((eot (list 'eot))
 1211      (xf (next-leaf-generator x eot))
 1212      (yf (next-leaf-generator y eot)))
 1213     (letrec ((loop (lambda (x y)
 1214              (cond ((not (eq? x y)) #f)
 1215                ((eq? eot x) #t)
 1216                (else (loop (xf) (yf)))))))
 1217       (loop (xf) (yf)))))
 1218 (define (test-cont)
 1219   (newline)
 1220   (display ";testing continuations; ")
 1221   (newline)
 1222   (SECTION 6 9)
 1223   (test #t leaf-eq? '(a (b (c))) '((a) b c))
 1224   (test #f leaf-eq? '(a (b (c))) '((a) b c d))
 1225   (report-errs))
 1226 
 1227 ;;; Test Optional R4RS DELAY syntax and FORCE procedure
 1228 (define (test-delay)
 1229   (newline)
 1230   (display ";testing DELAY and FORCE; ")
 1231   (newline)
 1232   (SECTION 6 9)
 1233   (test 3 'delay (force (delay (+ 1 2))))
 1234   (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
 1235             (list (force p) (force p))))
 1236   (test 2 'delay (letrec ((a-stream
 1237                (letrec ((next (lambda (n)
 1238                         (cons n (delay (next (+ n 1)))))))
 1239                  (next 0)))
 1240               (head car)
 1241               (tail (lambda (stream) (force (cdr stream)))))
 1242            (head (tail (tail a-stream)))))
 1243   (letrec ((count 0)
 1244        (p (delay (begin (set! count (+ count 1))
 1245                 (if (> count x)
 1246                 count
 1247                 (force p)))))
 1248        (x 5))
 1249     (test 6 force p)
 1250     (set! x 10)
 1251     (test 6 force p))
 1252   (test 3 'force
 1253     (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
 1254          (c #f))
 1255       (force p)))
 1256   (report-errs))
 1257 
 1258 (SECTION 6 10 1)
 1259 (test #t input-port? (current-input-port))
 1260 (test #t output-port? (current-output-port))
 1261 (test #t call-with-input-file "r4rstest.scm" input-port?)
 1262 (define this-file (open-input-file "r4rstest.scm"))
 1263 (test #t input-port? this-file)
 1264 (SECTION 6 10 2)
 1265 (test #\; peek-char this-file)
 1266 (test #\; read-char this-file)
 1267 (test '(define cur-section '()) read this-file)
 1268 (test #\( peek-char this-file)
 1269 (test '(define errs '()) read this-file)
 1270 (close-input-port this-file)
 1271 (close-input-port this-file)
 1272 (define (check-test-file name)
 1273   (define test-file (open-input-file name))
 1274   (test #t 'input-port?
 1275     (call-with-input-file
 1276         name
 1277       (lambda (test-file)
 1278         (test load-test-obj read test-file)
 1279         (test #t eof-object? (peek-char test-file))
 1280         (test #t eof-object? (read-char test-file))
 1281         (input-port? test-file))))
 1282   (test #\; read-char test-file)
 1283   (test #\; read-char test-file)
 1284   (test #\; read-char test-file)
 1285   (test write-test-obj read test-file)
 1286   (test load-test-obj read test-file)
 1287   (close-input-port test-file))
 1288 (SECTION 6 10 3)
 1289 (define write-test-obj
 1290   '(#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
 1291 (define load-test-obj
 1292   (list 'define 'foo (list 'quote write-test-obj)))
 1293 (test #t call-with-output-file
 1294       "tmp1"
 1295       (lambda (test-file)
 1296     (write-char #\; test-file)
 1297     (display #\; test-file)
 1298     (display ";" test-file)
 1299     (write write-test-obj test-file)
 1300     (newline test-file)
 1301     (write load-test-obj test-file)
 1302     (output-port? test-file)))
 1303 (check-test-file "tmp1")
 1304 
 1305 (define test-file (open-output-file "tmp2"))
 1306 (write-char #\; test-file)
 1307 (display #\; test-file)
 1308 (display ";" test-file)
 1309 (write write-test-obj test-file)
 1310 (newline test-file)
 1311 (write load-test-obj test-file)
 1312 (test #t output-port? test-file)
 1313 (close-output-port test-file)
 1314 (check-test-file "tmp2")
 1315 (define (test-sc4)
 1316   (newline)
 1317   (display ";testing scheme 4 functions; ")
 1318   (newline)
 1319   (SECTION 6 7)
 1320   (test '(#\P #\space #\l) string->list "P l")
 1321   (test '() string->list "")
 1322   (test "1\\\"" list->string '(#\1 #\\ #\"))
 1323   (test "" list->string '())
 1324   (SECTION 6 8)
 1325   (test '(dah dah didah) vector->list '#(dah dah didah))
 1326   (test '() vector->list '#())
 1327   (test '#(dididit dah) list->vector '(dididit dah))
 1328   (test '#() list->vector '())
 1329   (SECTION 6 10 4)
 1330   (load "tmp1")
 1331   (test write-test-obj 'load foo)
 1332   (report-errs))
 1333 
 1334 (report-errs)
 1335 (let ((have-inexacts?
 1336        (and (string->number "0.0") (inexact? (string->number "0.0"))))
 1337       (have-bignums?
 1338        (let ((n (string->number
 1339          "1427247692705959881058285969449495136382746625")))
 1340      (and n (exact? n)))))
 1341   (cond (have-inexacts?
 1342      (test-inexact)
 1343      (test-inexact-printing)))
 1344   (if have-bignums? (test-bignum))
 1345   (if (and have-inexacts? have-bignums?)
 1346       (test-numeric-predicates)))
 1347 
 1348 (newline)
 1349 (display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
 1350 (newline)
 1351 (display "(test-cont) (test-sc4) (test-delay)")
 1352 (newline)
 1353 "last item in file"