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" |