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