Import Upstream version 5d2upstream/5d2

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