Import Upstream version 5d9upstream/5d9

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