summaryrefslogtreecommitdiffstats
path: root/r4rstest.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit3278b75942bdbe706f7a0fba87729bb1e935b68b (patch)
treedcad4048dfc0b38367047426b2b14501bf5ff257 /r4rstest.scm
parentdb04688faa20f3576257c0fe41752ec435beab9a (diff)
downloadscm-3278b75942bdbe706f7a0fba87729bb1e935b68b.tar.gz
scm-3278b75942bdbe706f7a0fba87729bb1e935b68b.zip
Import Upstream version 5d2upstream/5d2
Diffstat (limited to 'r4rstest.scm')
-rw-r--r--r4rstest.scm124
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))