diff options
Diffstat (limited to 'r4rstest.scm')
| -rw-r--r-- | r4rstest.scm | 124 |
1 files changed, 118 insertions, 6 deletions
diff --git a/r4rstest.scm b/r4rstest.scm index 35da2f4..bc3f2f7 100644 --- a/r4rstest.scm +++ b/r4rstest.scm @@ -39,7 +39,7 @@ ;;; 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 jaffer @ai.mit.edu (define cur-section '())(define errs '()) (define SECTION (lambda args @@ -210,6 +210,9 @@ (loop (cdr numbers) (cons (car numbers) nonneg) neg))))) +;;From: Allegro Petrofsky <Allegro@Petrofsky.Berkeley.CA.US> +(test -1 'let (let ((f -)) (let f ((n (f 1))) n))) + (SECTION 4 2 6) (test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) (test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) @@ -310,6 +313,31 @@ (let ((x '#())) (test #t eq? x x)) (let ((x (lambda (x) x))) (test #t eq? x x)) +(define test-eq?-eqv?-agreement + (lambda (obj1 obj2) + (cond ((eq? (eq? obj1 obj2) (eqv? obj1 obj2))) + (else + (record-error (list #f #t (list 'test-eq?-eqv?-agreement obj1 obj2))) + (display "eqv? and eq? disagree about ") + (write obj1) + (display #\ ) + (write obj2) + (newline))))) + +(test-eq?-eqv?-agreement '#f '#f) +(test-eq?-eqv?-agreement '#t '#t) +(test-eq?-eqv?-agreement '#t '#f) +(test-eq?-eqv?-agreement '(a) '(a)) +(test-eq?-eqv?-agreement '(a) '(b)) +(test-eq?-eqv?-agreement car car) +(test-eq?-eqv?-agreement car cdr) +(test-eq?-eqv?-agreement (list 'a) (list 'a)) +(test-eq?-eqv?-agreement (list 'a) (list 'b)) +(test-eq?-eqv?-agreement '#(a) '#(a)) +(test-eq?-eqv?-agreement '#(a) '#(b)) +(test-eq?-eqv?-agreement "abc" "abc") +(test-eq?-eqv?-agreement "abc" "abz") + (test #t equal? 'a 'a) (test #t equal? '(a) '(a)) (test #t equal? '(a (b) c) '(a (b) c)) @@ -541,6 +569,8 @@ (test f1.0 round f0.8) (test f4.0 round f3.5) (test f4.0 round f4.5) + (test 1 expt 0 0) + (test 0 expt 0 1) (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) @@ -561,6 +591,87 @@ (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) (report-errs)) +(define (test-inexact-printing) + (let ((f0.0 (string->number "0.0")) + (f0.5 (string->number "0.5")) + (f1.0 (string->number "1.0")) + (f2.0 (string->number "2.0"))) + (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) 1))) + (f (/ x (expt 2 e)))) + (list f e)))) + + (define float-precision + (let ((mantissa-bits + (do ((i 0 (+ i 1)) + (eps f1.0 (* f0.5 eps))) + ((= f1.0 (+ f1.0 eps)) + i))) + (minval + (do ((x f1.0 (* f0.5 x))) + ((zero? (* f0.5 x)) x)))) + (lambda (x) + (apply (lambda (f e) + (let ((eps + (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits)))) + ((zero? f) minval) + (else (expt f2.0 (- e mantissa-bits)))))) + (if (zero? eps) ;Happens if gradual underflow. + minval + eps))) + (slow-frexp x))))) + + (define (float-print-test x) + (define (testit number) + (eqv? number (string->number (number->string number)))) + (let ((eps (float-precision x)) + (all-ok? #t)) + (do ((j -100 (+ j 1))) + ((or (not all-ok?) (> j 100)) all-ok?) + (let* ((xx (+ x (* j eps))) + (ok? (testit xx))) + (cond ((not ok?) + (display "Number readback failure for ") + (display `(+ ,x (* ,j ,eps))) + (newline) + (display xx) + (newline) + (set! all-ok? #f)) + ;; (else (display xx) (newline)) + ))))) + + (define (mult-float-print-test x) + (let ((res #t)) + (for-each + (lambda (mult) + (or (float-print-test (* mult x)) (set! res #f))) + (map string->number + '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100" + "0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100"))) + res)) + + (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 + (string->number "3.0"))) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "7.0"))) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "3.1415926535897931"))) + (test #t 'mult-float-print-test (mult-float-print-test + (string->number "2.7182818284590451"))))) + (define (test-bignum) (define tb (lambda (n1 n2) @@ -569,7 +680,7 @@ (newline) (display ";testing bignums; ") (newline) - (SECTION 6 5 5) + (SECTION 6 5 7) (test 0 modulo 33333333333333333333 3) (test 0 modulo 33333333333333333333 -3) (test 0 remainder 33333333333333333333 3) @@ -598,12 +709,12 @@ (test 0 modulo -2177452800 -86400) (test #t 'remainder (tb 281474976710655325431 65535)) (test #t 'remainder (tb 281474976710655325430 65535)) - (SECTION 6 5 6) + (SECTION 6 5 8) (test 281474976710655325431 string->number "281474976710655325431") (test "281474976710655325431" number->string 281474976710655325431) (report-errs)) -(SECTION 6 5 6) +(SECTION 6 5 9) (test "0" number->string 0) (test "100" number->string 100) (test "100" number->string 256 16) @@ -1034,8 +1145,9 @@ (report-errs)) (report-errs) -(if (and (string->number "0.0") (inexact? (string->number "0.0"))) - (test-inexact)) +(cond ((and (string->number "0.0") (inexact? (string->number "0.0"))) + (test-inexact) + (test-inexact-printing))) (let ((n (string->number "281474976710655325431"))) (if (and n (exact? n)) |