diff options
Diffstat (limited to 'r4rstest.scm')
| -rw-r--r-- | r4rstest.scm | 67 |
1 files changed, 44 insertions, 23 deletions
diff --git a/r4rstest.scm b/r4rstest.scm index 3683f0d..f6f3ae0 100644 --- a/r4rstest.scm +++ b/r4rstest.scm @@ -1,4 +1,4 @@ -;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by the @@ -30,16 +30,16 @@ ;;; There are three optional tests: ;;; (TEST-CONT) tests multiple returns from call-with-current-continuation -;;; +;;; ;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE -;;; +;;; ;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by ;;; either standard. ;;; If you are testing a R3RS version which does not have `list?' do: ;;; (define list? #f) -;;; send corrections or additions to jaffer @ai.mit.edu +;;; send corrections or additions to agj @ alum.mit.edu (define cur-section '())(define errs '()) (define SECTION (lambda args @@ -224,7 +224,7 @@ `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) ;;; sqt is defined here because not all implementations are required to -;;; support it. +;;; support it. (define (sqt x) (do ((i 0 (+ i 1))) ((> (* i i) x) (- i 1)))) @@ -557,6 +557,21 @@ (test 288 lcm 32 -36) (test 1 lcm) +(SECTION 6 5 5) +;;; Implementations which don't allow division by 0 can have fragile +;;; string->number. +(define (test-string->number str) + (define ans (string->number str)) + (cond ((not ans) #t) ((number? ans) #t) (else ans))) +(for-each (lambda (str) (test #t test-string->number str)) + '("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0" + "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i" + "#i" "#e" "#" "#i0/0")) +(cond ((number? (string->number "1+1i")) ;More kawa bait + (test #t number? (string->number "#i-i")) + (test #t number? (string->number "#i+i")) + (test #t number? (string->number "#i2+i")))) + ;;;;From: fred@sce.carleton.ca (Fred J Kaudel) ;;; Modified by jaffer. (define (test-inexact) @@ -574,11 +589,17 @@ (newline) (display ";testing inexact numbers; ") (newline) + (SECTION 6 2) + (test #f eqv? 1 f1.0) + (test #f eqv? 0 f0.0) (SECTION 6 5 5) (test #t inexact? f3.9) - (test #t 'inexact? (inexact? (max f3.9 4))) - (test f4.0 'max (max f3.9 4)) - (test f4.0 'exact->inexact (exact->inexact 4)) + (test #t 'max (inexact? (max f3.9 4))) + (test f4.0 max f3.9 4) + (test f4.0 exact->inexact 4) + (test f4.0 exact->inexact 4.0) + (test 4 inexact->exact 4) + (test 4 inexact->exact 4.0) (test (- f4.0) round (- f4.5)) (test (- f4.0) round (- f3.5)) (test (- f4.0) round (- f3.9)) @@ -618,14 +639,14 @@ (define log2 (let ((l2 (log 2))) (lambda (x) (/ (log x) l2)))) - + (define (slow-frexp x) (if (zero? x) (list f0.0 0) (let* ((l2 (log2 x)) (e (floor (log2 x))) (e (if (= l2 e) - (inexact->exact e) + (inexact->exact e) (+ (inexact->exact e) 1))) (f (/ x (expt 2 e)))) (list f e)))) @@ -649,7 +670,7 @@ minval eps))) (slow-frexp x))))) - + (define (float-print-test x) (define (testit number) (eqv? number (string->number (number->string number)))) @@ -671,7 +692,7 @@ (define (mult-float-print-test x) (let ((res #t)) - (for-each + (for-each (lambda (mult) (or (float-print-test (* mult x)) (set! res #f))) (map string->number @@ -682,7 +703,7 @@ (SECTION 6 5 6) (test #t 'float-print-test (float-print-test f0.0)) (test #t 'mult-float-print-test (mult-float-print-test f1.0)) - (test #t 'mult-float-print-test (mult-float-print-test + (test #t 'mult-float-print-test (mult-float-print-test (string->number "3.0"))) (test #t 'mult-float-print-test (mult-float-print-test (string->number "7.0"))) @@ -1023,15 +1044,15 @@ (test '(1 2 3) map * '(1 2 3)) (test '(-1 -2 -3) map - '(1 2 3)) (test '#(0 1 4 9 16) 'for-each - (let ((v (make-vector 5))) - (for-each (lambda (i) (vector-set! v i (* i i))) - '(0 1 2 3 4)) - v)) + (let ((v (make-vector 5))) + (for-each (lambda (i) (vector-set! v i (* i i))) + '(0 1 2 3 4)) + v)) (test -3 call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) (if (negative? x) (exit x))) - '(54 0 37 -3 245 19)) - #t)) + (lambda (exit) + (for-each (lambda (x) (if (negative? x) (exit x))) + '(54 0 37 -3 245 19)) + #t)) (define list-length (lambda (obj) (call-with-current-continuation @@ -1049,7 +1070,7 @@ ;;; other than escape procedures. I am indebted to ;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this ;;; code. The function leaf-eq? compares the leaves of 2 arbitrary -;;; trees constructed of conses. +;;; trees constructed of conses. (define (next-leaf-generator obj eot) (letrec ((return #f) (cont (lambda (x) @@ -1191,7 +1212,7 @@ (report-errs)) (report-errs) -(let ((have-inexacts? +(let ((have-inexacts? (and (string->number "0.0") (inexact? (string->number "0.0")))) (have-bignums? (let ((n (string->number "281474976710655325431"))) |