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