/[scm]/scm/r4rstest.scm
ViewVC logotype

Contents of /scm/r4rstest.scm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.60 - (show annotations) (download)
Fri Aug 4 17:30:51 2023 UTC (8 months, 3 weeks ago) by shouman
Branch: MAIN
CVS Tags: scm-5f4, HEAD
Branch point for: devel
Changes since 1.59: +10 -0 lines
Summary:   (test-bignum): Added some tests of EXPT requiring bignums.

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 (float-rw-range-test))
811 (test #t 'float-powers-of-2-test (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 sqr
819 (lambda (n1)
820 (= (* n1 n1)
821 (+ (* (+ n1 1) (- n1 1)) 1))))
822 (define (test-ash base . shifts)
823 (let recur ((x base)
824 (sum 0)
825 (shifts shifts))
826 (if (null? shifts)
827 (ash x (- sum))
828 (recur (ash x (car shifts))
829 (+ sum (car shifts))
830 (cdr shifts)))))
831 (define b3-3 (string->number "33333333333333333333"))
832 (define b3-2 (string->number "33333333333333333332"))
833 (define b3-0 (string->number "33333333333333333330"))
834 (define b1-1 (string->number "11111111111111111111"))
835 (define b2-0 (string->number "2177452800"))
836 (define b17 (string->number "#x10000"))
837 (define b21 (string->number "#x100000"))
838 (define b33 (string->number "#x100000000"))
839 (define b37 (string->number "#x1000000000"))
840 (define b40 (string->number "#x8000000000"))
841 (define b65 (string->number "#x10000000000000000"))
842 (define b69 (string->number "#x100000000000000000"))
843 (newline)
844 (display ";testing bignums; ")
845 (newline)
846 (test b33 * b17 b17)
847 (test #t 'arithmetic (sqr b17))
848 (test b37 * b17 b21)
849 (test b65 * b33 b33)
850 (test #t 'arithmetic (sqr b33))
851 (test b69 * b33 b37)
852 (test 1 test-ash 1 640)
853 (test -1 test-ash -1 640)
854 (test #xABCD test-ash #xABCD 8 19 1 1 200 -64)
855 (test b17 expt 2 16)
856 (test b21 expt 2 20)
857 (test b37 expt 2 36)
858 (test b37 expt -2 36)
859 (test b40 expt 2 39)
860 (test b40 (lambda (b p) (- (expt b p))) -2 39)
861 (test b65 expt 2 64)
862 (test b65 expt -2 64)
863 (test b69 expt 2 68)
864 (test b69 expt -2 68)
865
866 (SECTION 6 5 7)
867 (test 0 modulo b3-3 3)
868 (test 0 modulo b3-3 -3)
869 (test 0 remainder b3-3 3)
870 (test 0 remainder b3-3 -3)
871 (test 2 modulo b3-2 3)
872 (test -1 modulo b3-2 -3)
873 (test 2 remainder b3-2 3)
874 (test 2 remainder b3-2 -3)
875 (test 1 modulo (- b3-2) 3)
876 (test -2 modulo (- b3-2) -3)
877 (test -2 remainder (- b3-2) 3)
878 (test -2 remainder (- b3-2) -3)
879
880 (test 3 modulo 3 b3-3)
881 (test b3-0 modulo -3 b3-3)
882 (test 3 remainder 3 b3-3)
883 (test -3 remainder -3 b3-3)
884 (test (- b3-0) modulo 3 (- b3-3))
885 (test -3 modulo -3 (- b3-3))
886 (test 3 remainder 3 (- b3-3))
887 (test -3 remainder -3 (- b3-3))
888
889 (test 0 modulo (- b2-0) 86400)
890 (test 0 modulo b2-0 -86400)
891 (test 0 modulo b2-0 86400)
892 (test 0 modulo (- b2-0) -86400)
893 (test 0 modulo 0 (- b2-0))
894 (test #t 'remainder (tb (string->number "281474976710655325431") 65535))
895 (test #t 'remainder (tb (string->number "281474976710655325430") 65535))
896
897 (test b1-1 gcd b3-3 b1-1)
898 (test 1 gcd b3-2 b1-1)
899 (test 1 gcd b3-0 b1-1)
900 (test 3 gcd b3-3 b3-0)
901
902 (test b3-3 lcm b3-3 b1-1)
903 (test b3-3 lcm -3 b1-1)
904
905 (let ((n (string->number
906 "30414093201713378043612608166064768844377641568960512")))
907 (and n (exact? n)
908 (do ((pow3 1 (* 3 pow3))
909 (cnt 21 (+ -1 cnt)))
910 ((negative? cnt)
911 (zero? (modulo n pow3))))))
912
913 (SECTION 6 5 8)
914 (test "281474976710655325431" number->string
915 (string->number "281474976710655325431"))
916 (report-errs))
917
918 (define (test-numeric-predicates)
919 (let* ((big-ex (expt 2 150))
920 (big-inex (exact->inexact big-ex)))
921 (newline)
922 (display ";testing bignum-inexact comparisons;")
923 (newline)
924 (SECTION 6 5 5)
925 (test #f = (+ big-ex 1) big-inex (- big-ex 1))
926 (test #f = big-inex (+ big-ex 1) (- big-ex 1))
927 (test #t < (- (inexact->exact big-inex) 1)
928 big-inex
929 (+ (inexact->exact big-inex) 1))))
930
931
932 (SECTION 6 5 9)
933 (test "0" number->string 0)
934 (test "100" number->string 100)
935 (test "100" number->string 256 16)
936 (test 100 string->number "100")
937 (test 256 string->number "100" 16)
938 (test #f string->number "")
939 (test #f string->number ".")
940 (test #f string->number "d")
941 (test #f string->number "D")
942 (test #f string->number "i")
943 (test #f string->number "I")
944 (test #f string->number "3i")
945 (test #f string->number "3I")
946 (test #f string->number "33i")
947 (test #f string->number "33I")
948 (test #f string->number "3.3i")
949 (test #f string->number "3.3I")
950 (test #f string->number "-")
951 (test #f string->number "+")
952 (test #t 'string->number (or (not (string->number "80000000" 16))
953 (positive? (string->number "80000000" 16))))
954 (test #t 'string->number (or (not (string->number "-80000000" 16))
955 (negative? (string->number "-80000000" 16))))
956
957 (SECTION 6 6)
958 (test #t eqv? '#\ #\Space)
959 (test #t eqv? #\space '#\Space)
960 (test #t char? #\a)
961 (test #t char? #\()
962 (test #t char? #\space)
963 (test #t char? '#\newline)
964
965 (test #f char=? #\A #\B)
966 (test #f char=? #\a #\b)
967 (test #f char=? #\9 #\0)
968 (test #t char=? #\A #\A)
969
970 (test #t char<? #\A #\B)
971 (test #t char<? #\a #\b)
972 (test #f char<? #\9 #\0)
973 (test #f char<? #\A #\A)
974
975 (test #f char>? #\A #\B)
976 (test #f char>? #\a #\b)
977 (test #t char>? #\9 #\0)
978 (test #f char>? #\A #\A)
979
980 (test #t char<=? #\A #\B)
981 (test #t char<=? #\a #\b)
982 (test #f char<=? #\9 #\0)
983 (test #t char<=? #\A #\A)
984
985 (test #f char>=? #\A #\B)
986 (test #f char>=? #\a #\b)
987 (test #t char>=? #\9 #\0)
988 (test #t char>=? #\A #\A)
989
990 (test #f char-ci=? #\A #\B)
991 (test #f char-ci=? #\a #\B)
992 (test #f char-ci=? #\A #\b)
993 (test #f char-ci=? #\a #\b)
994 (test #f char-ci=? #\9 #\0)
995 (test #t char-ci=? #\A #\A)
996 (test #t char-ci=? #\A #\a)
997
998 (test #t char-ci<? #\A #\B)
999 (test #t char-ci<? #\a #\B)
1000 (test #t char-ci<? #\A #\b)
1001 (test #t char-ci<? #\a #\b)
1002 (test #f char-ci<? #\9 #\0)
1003 (test #f char-ci<? #\A #\A)
1004 (test #f char-ci<? #\A #\a)
1005
1006 (test #f char-ci>? #\A #\B)
1007 (test #f char-ci>? #\a #\B)
1008 (test #f char-ci>? #\A #\b)
1009 (test #f char-ci>? #\a #\b)
1010 (test #t char-ci>? #\9 #\0)
1011 (test #f char-ci>? #\A #\A)
1012 (test #f char-ci>? #\A #\a)
1013
1014 (test #t char-ci<=? #\A #\B)
1015 (test #t char-ci<=? #\a #\B)
1016 (test #t char-ci<=? #\A #\b)
1017 (test #t char-ci<=? #\a #\b)
1018 (test #f char-ci<=? #\9 #\0)
1019 (test #t char-ci<=? #\A #\A)
1020 (test #t char-ci<=? #\A #\a)
1021
1022 (test #f char-ci>=? #\A #\B)
1023 (test #f char-ci>=? #\a #\B)
1024 (test #f char-ci>=? #\A #\b)
1025 (test #f char-ci>=? #\a #\b)
1026 (test #t char-ci>=? #\9 #\0)
1027 (test #t char-ci>=? #\A #\A)
1028 (test #t char-ci>=? #\A #\a)
1029
1030 (test #t char-alphabetic? #\a)
1031 (test #t char-alphabetic? #\A)
1032 (test #t char-alphabetic? #\z)
1033 (test #t char-alphabetic? #\Z)
1034 (test #f char-alphabetic? #\0)
1035 (test #f char-alphabetic? #\9)
1036 (test #f char-alphabetic? #\space)
1037 (test #f char-alphabetic? #\;)
1038
1039 (test #f char-numeric? #\a)
1040 (test #f char-numeric? #\A)
1041 (test #f char-numeric? #\z)
1042 (test #f char-numeric? #\Z)
1043 (test #t char-numeric? #\0)
1044 (test #t char-numeric? #\9)
1045 (test #f char-numeric? #\space)
1046 (test #f char-numeric? #\;)
1047
1048 (test #f char-whitespace? #\a)
1049 (test #f char-whitespace? #\A)
1050 (test #f char-whitespace? #\z)
1051 (test #f char-whitespace? #\Z)
1052 (test #f char-whitespace? #\0)
1053 (test #f char-whitespace? #\9)
1054 (test #t char-whitespace? #\space)
1055 (test #f char-whitespace? #\;)
1056
1057 (test #f char-upper-case? #\0)
1058 (test #f char-upper-case? #\9)
1059 (test #f char-upper-case? #\space)
1060 (test #f char-upper-case? #\;)
1061
1062 (test #f char-lower-case? #\0)
1063 (test #f char-lower-case? #\9)
1064 (test #f char-lower-case? #\space)
1065 (test #f char-lower-case? #\;)
1066
1067 (test #\. integer->char (char->integer #\.))
1068 (test #\A integer->char (char->integer #\A))
1069 (test #\a integer->char (char->integer #\a))
1070 (test #\A char-upcase #\A)
1071 (test #\A char-upcase #\a)
1072 (test #\a char-downcase #\A)
1073 (test #\a char-downcase #\a)
1074 (SECTION 6 7)
1075 (test #t string? "The word \"recursion\\\" has many meanings.")
1076 ;(test #t string? "")
1077 (define f (make-string 3 #\*))
1078 (test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
1079 (test "abc" string #\a #\b #\c)
1080 (test "" string)
1081 (test 3 string-length "abc")
1082 (test #\a string-ref "abc" 0)
1083 (test #\c string-ref "abc" 2)
1084 (test 0 string-length "")
1085 (test "" substring "ab" 0 0)
1086 (test "" substring "ab" 1 1)
1087 (test "" substring "ab" 2 2)
1088 (test "a" substring "ab" 0 1)
1089 (test "b" substring "ab" 1 2)
1090 (test "ab" substring "ab" 0 2)
1091 (test "foobar" string-append "foo" "bar")
1092 (test "foo" string-append "foo")
1093 (test "foo" string-append "foo" "")
1094 (test "foo" string-append "" "foo")
1095 (test "" string-append)
1096 (test "" make-string 0)
1097 (test #t string=? "" "")
1098 (test #f string<? "" "")
1099 (test #f string>? "" "")
1100 (test #t string<=? "" "")
1101 (test #t string>=? "" "")
1102 (test #t string-ci=? "" "")
1103 (test #f string-ci<? "" "")
1104 (test #f string-ci>? "" "")
1105 (test #t string-ci<=? "" "")
1106 (test #t string-ci>=? "" "")
1107
1108 (test #f string=? "A" "B")
1109 (test #f string=? "a" "b")
1110 (test #f string=? "9" "0")
1111 (test #t string=? "A" "A")
1112
1113 (test #t string<? "A" "B")
1114 (test #t string<? "a" "b")
1115 (test #f string<? "9" "0")
1116 (test #f string<? "A" "A")
1117
1118 (test #f string>? "A" "B")
1119 (test #f string>? "a" "b")
1120 (test #t string>? "9" "0")
1121 (test #f string>? "A" "A")
1122
1123 (test #t string<=? "A" "B")
1124 (test #t string<=? "a" "b")
1125 (test #f string<=? "9" "0")
1126 (test #t string<=? "A" "A")
1127
1128 (test #f string>=? "A" "B")
1129 (test #f string>=? "a" "b")
1130 (test #t string>=? "9" "0")
1131 (test #t string>=? "A" "A")
1132
1133 (test #f string-ci=? "A" "B")
1134 (test #f string-ci=? "a" "B")
1135 (test #f string-ci=? "A" "b")
1136 (test #f string-ci=? "a" "b")
1137 (test #f string-ci=? "9" "0")
1138 (test #t string-ci=? "A" "A")
1139 (test #t string-ci=? "A" "a")
1140
1141 (test #t string-ci<? "A" "B")
1142 (test #t string-ci<? "a" "B")
1143 (test #t string-ci<? "A" "b")
1144 (test #t string-ci<? "a" "b")
1145 (test #f string-ci<? "9" "0")
1146 (test #f string-ci<? "A" "A")
1147 (test #f string-ci<? "A" "a")
1148
1149 (test #f string-ci>? "A" "B")
1150 (test #f string-ci>? "a" "B")
1151 (test #f string-ci>? "A" "b")
1152 (test #f string-ci>? "a" "b")
1153 (test #t string-ci>? "9" "0")
1154 (test #f string-ci>? "A" "A")
1155 (test #f string-ci>? "A" "a")
1156
1157 (test #t string-ci<=? "A" "B")
1158 (test #t string-ci<=? "a" "B")
1159 (test #t string-ci<=? "A" "b")
1160 (test #t string-ci<=? "a" "b")
1161 (test #f string-ci<=? "9" "0")
1162 (test #t string-ci<=? "A" "A")
1163 (test #t string-ci<=? "A" "a")
1164
1165 (test #f string-ci>=? "A" "B")
1166 (test #f string-ci>=? "a" "B")
1167 (test #f string-ci>=? "A" "b")
1168 (test #f string-ci>=? "a" "b")
1169 (test #t string-ci>=? "9" "0")
1170 (test #t string-ci>=? "A" "A")
1171 (test #t string-ci>=? "A" "a")
1172 (SECTION 6 8)
1173 (test #t vector? '#(0 (2 2 2 2) "Anna"))
1174 ;(test #t vector? '#())
1175 (test '#(a b c) vector 'a 'b 'c)
1176 (test '#() vector)
1177 (test 3 vector-length '#(0 (2 2 2 2) "Anna"))
1178 (test 0 vector-length '#())
1179 (test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
1180 (test '#(0 ("Sue" "Sue") "Anna") 'vector-set
1181 (let ((vec (vector 0 '(2 2 2 2) "Anna")))
1182 (vector-set! vec 1 '("Sue" "Sue"))
1183 vec))
1184 (test '#(hi hi) make-vector 2 'hi)
1185 (test '#() make-vector 0)
1186 (test '#() make-vector 0 'a)
1187 (SECTION 6 9)
1188 (test #t procedure? car)
1189 (test #f procedure? 'car)
1190 (test #t procedure? (lambda (x) (* x x)))
1191 (test #f procedure? '(lambda (x) (* x x)))
1192 (test #t call-with-current-continuation procedure?)
1193 (test #t procedure? /)
1194 (test 7 apply + (list 3 4))
1195 (test 7 apply (lambda (a b) (+ a b)) (list 3 4))
1196 (test 17 apply + 10 (list 3 4))
1197 (test '() apply list '())
1198 (define compose (lambda (f g) (lambda args (f (apply g args)))))
1199 (test 30 (compose sqt *) 12 75)
1200
1201 (test '(b e h) map cadr '((a b) (d e) (g h)))
1202 (test '(5 7 9) map + '(1 2 3) '(4 5 6))
1203 (test '(1 2 3) map + '(1 2 3))
1204 (test '(1 2 3) map * '(1 2 3))
1205 (test '(-1 -2 -3) map - '(1 2 3))
1206 (test '#(0 1 4 9 16) 'for-each
1207 (let ((v (make-vector 5)))
1208 (for-each (lambda (i) (vector-set! v i (* i i)))
1209 '(0 1 2 3 4))
1210 v))
1211 (test -3 call-with-current-continuation
1212 (lambda (exit)
1213 (for-each (lambda (x) (if (negative? x) (exit x)))
1214 '(54 0 37 -3 245 19))
1215 #t))
1216 (define list-length
1217 (lambda (obj)
1218 (call-with-current-continuation
1219 (lambda (return)
1220 (letrec ((r (lambda (obj) (cond ((null? obj) 0)
1221 ((pair? obj) (+ (r (cdr obj)) 1))
1222 (else (return #f))))))
1223 (r obj))))))
1224 (test 4 list-length '(1 2 3 4))
1225 (test #f list-length '(a b . c))
1226 (test '() map cadr '())
1227
1228 ;;; This tests full conformance of call-with-current-continuation. It
1229 ;;; is a separate test because some schemes do not support call/cc
1230 ;;; other than escape procedures. I am indebted to
1231 ;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
1232 ;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
1233 ;;; trees constructed of conses.
1234 (define (next-leaf-generator obj eot)
1235 (letrec ((return #f)
1236 (cont (lambda (x)
1237 (recur obj)
1238 (set! cont (lambda (x) (return eot)))
1239 (cont #f)))
1240 (recur (lambda (obj)
1241 (if (pair? obj)
1242 (for-each recur obj)
1243 (call-with-current-continuation
1244 (lambda (c)
1245 (set! cont c)
1246 (return obj)))))))
1247 (lambda () (call-with-current-continuation
1248 (lambda (ret) (set! return ret) (cont #f))))))
1249 (define (leaf-eq? x y)
1250 (let* ((eot (list 'eot))
1251 (xf (next-leaf-generator x eot))
1252 (yf (next-leaf-generator y eot)))
1253 (letrec ((loop (lambda (x y)
1254 (cond ((not (eq? x y)) #f)
1255 ((eq? eot x) #t)
1256 (else (loop (xf) (yf)))))))
1257 (loop (xf) (yf)))))
1258 (define (test-cont)
1259 (newline)
1260 (display ";testing continuations; ")
1261 (newline)
1262 (SECTION 6 9)
1263 (test #t leaf-eq? '(a (b (c))) '((a) b c))
1264 (test #f leaf-eq? '(a (b (c))) '((a) b c d))
1265 (report-errs))
1266
1267 ;;; Test Optional R4RS DELAY syntax and FORCE procedure
1268 (define (test-delay)
1269 (newline)
1270 (display ";testing DELAY and FORCE; ")
1271 (newline)
1272 (SECTION 6 9)
1273 (test 3 'delay (force (delay (+ 1 2))))
1274 (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
1275 (list (force p) (force p))))
1276 (test 2 'delay (letrec ((a-stream
1277 (letrec ((next (lambda (n)
1278 (cons n (delay (next (+ n 1)))))))
1279 (next 0)))
1280 (head car)
1281 (tail (lambda (stream) (force (cdr stream)))))
1282 (head (tail (tail a-stream)))))
1283 (letrec ((count 0)
1284 (p (delay (begin (set! count (+ count 1))
1285 (if (> count x)
1286 count
1287 (force p)))))
1288 (x 5))
1289 (test 6 force p)
1290 (set! x 10)
1291 (test 6 force p))
1292 (test 3 'force
1293 (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
1294 (c #f))
1295 (force p)))
1296 (report-errs))
1297
1298 (SECTION 6 10 1)
1299 (test #t input-port? (current-input-port))
1300 (test #t output-port? (current-output-port))
1301 (test #t call-with-input-file "r4rstest.scm" input-port?)
1302 (define this-file (open-input-file "r4rstest.scm"))
1303 (test #t input-port? this-file)
1304 (SECTION 6 10 2)
1305 (test #\; peek-char this-file)
1306 (test #\; read-char this-file)
1307 (test '(define cur-section '()) read this-file)
1308 (test #\( peek-char this-file)
1309 (test '(define errs '()) read this-file)
1310 (close-input-port this-file)
1311 (close-input-port this-file)
1312 (define (check-test-file name)
1313 (define test-file (open-input-file name))
1314 (test #t 'input-port?
1315 (call-with-input-file
1316 name
1317 (lambda (test-file)
1318 (test load-test-obj read test-file)
1319 (test #t eof-object? (peek-char test-file))
1320 (test #t eof-object? (read-char test-file))
1321 (input-port? test-file))))
1322 (test #\; read-char test-file)
1323 (test #\; read-char test-file)
1324 (test #\; read-char test-file)
1325 (test write-test-obj read test-file)
1326 (test load-test-obj read test-file)
1327 (close-input-port test-file))
1328 (SECTION 6 10 3)
1329 (define write-test-obj
1330 '(#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
1331 (define load-test-obj
1332 (list 'define 'foo (list 'quote write-test-obj)))
1333 (test #t call-with-output-file
1334 "tmp1"
1335 (lambda (test-file)
1336 (write-char #\; test-file)
1337 (display #\; test-file)
1338 (display ";" test-file)
1339 (write write-test-obj test-file)
1340 (newline test-file)
1341 (write load-test-obj test-file)
1342 (output-port? test-file)))
1343 (check-test-file "tmp1")
1344
1345 (define test-file (open-output-file "tmp2"))
1346 (write-char #\; test-file)
1347 (display #\; test-file)
1348 (display ";" test-file)
1349 (write write-test-obj test-file)
1350 (newline test-file)
1351 (write load-test-obj test-file)
1352 (test #t output-port? test-file)
1353 (close-output-port test-file)
1354 (check-test-file "tmp2")
1355 (define (test-sc4)
1356 (newline)
1357 (display ";testing scheme 4 functions; ")
1358 (newline)
1359 (SECTION 6 7)
1360 (test '(#\P #\space #\l) string->list "P l")
1361 (test '() string->list "")
1362 (test "1\\\"" list->string '(#\1 #\\ #\"))
1363 (test "" list->string '())
1364 (SECTION 6 8)
1365 (test '(dah dah didah) vector->list '#(dah dah didah))
1366 (test '() vector->list '#())
1367 (test '#(dididit dah) list->vector '(dididit dah))
1368 (test '#() list->vector '())
1369 (SECTION 6 10 4)
1370 (load "tmp1")
1371 (test write-test-obj 'load foo)
1372 (report-errs))
1373
1374 (report-errs)
1375 (let ((have-inexacts?
1376 (and (string->number "0.0") (inexact? (string->number "0.0"))))
1377 (have-bignums?
1378 (let ((n (string->number
1379 "1427247692705959881058285969449495136382746625")))
1380 (and n (exact? n)))))
1381 (cond (have-inexacts?
1382 (test-inexact)
1383 (test-inexact-printing)))
1384 (if have-bignums? (test-bignum))
1385 (if (and have-inexacts? have-bignums?)
1386 (test-numeric-predicates)))
1387
1388 (newline)
1389 (display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
1390 (newline)
1391 (display "(test-cont) (test-sc4) (test-delay)")
1392 (newline)
1393 "last item in file"

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26