Import Upstream version 5d6upstream/5d6

1 files changed, 75 insertions, 24 deletions

diff --git a/r4rstest.scm b/r4rstest.scm
index bc3f2f7..3683f0d 100644
--- a/r4rstest.scm
+++ b/r4rstest.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000 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
@@ -184,9 +184,11 @@
 (test 34 'letrec x)
 (test 10 'letrec (letrec ((x 3)) (define x 10) x))
 (test 34 'letrec x)
+(define (s x) (if x (let () (set! s x) (set! x s))))
 (SECTION 4 2 3)
 (define x 0)
-(test 6 'begin (begin (set! x 5) (+ x 1)))
+(test 6 'begin (begin (set! x (begin (begin 5)))
+		      (begin ((begin +) (begin x) (begin (begin 1))))))
 (SECTION 4 2 4)
 (test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
 			    (i 0 (+ i 1)))
@@ -241,16 +243,31 @@
 (define first car)
 (test 1 'define (first '(1 2)))
 (define old-+ +)
-(define + (lambda (x y) (list y x)))
-(test '(3 6) add3 6)
+(begin (begin (begin)
+	      (begin (begin (begin) (define + (lambda (x y) (list y x)))
+			    (begin)))
+	      (begin))
+       (begin)
+       (begin (begin (begin) (test '(3 6) add3 6)
+		     (begin))))
 (set! + old-+)
 (test 9 add3 6)
+(begin)
+(begin (begin))
+(begin (begin (begin (begin))))
 (SECTION 5 2 2)
 (test 45 'define
-	(let ((x 5))
-		(define foo (lambda (y) (bar x y)))
-		(define bar (lambda (a b) (+ (* a b) a)))
-		(foo (+ x 3))))
+      (let ((x 5))
+	(begin (begin (begin)
+		      (begin (begin (begin) (define foo (lambda (y) (bar x y)))
+				    (begin)))
+		      (begin))
+	       (begin)
+	       (begin)
+	       (begin (define bar (lambda (a b) (+ (* a b) a))))
+	       (begin))
+	(begin)
+	(begin (foo (+ x 3)))))
 (define x 34)
 (define (foo) (define x 5) x)
 (test 5 foo)
@@ -523,6 +540,8 @@
 (test 1 remainder 13 -4)
 (test -1 modulo -13 -4)
 (test -1 remainder -13 -4)
+(test 0 modulo 0 86400)
+(test 0 modulo 0 -86400)
 (define (divtest n1 n2)
 	(= n1 (+ (* n2 (quotient n1 n2))
 		 (remainder n1 n2))))
@@ -551,7 +570,6 @@
   (define f0.8 (string->number "0.8"))
   (define f1.0 (string->number "1.0"))
   (define wto write-test-obj)
-  (define dto display-test-obj)
   (define lto load-test-obj)
   (newline)
   (display ";testing inexact numbers; ")
@@ -571,20 +589,21 @@
   (test f4.0 round f4.5)
   (test 1 expt 0 0)
   (test 0 expt 0 1)
+  (test (atan 1) atan 1 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)))
   (test #t call-with-output-file
       "tmp3"
       (lambda (test-file)
 	(write-char #\; test-file)
-	(display write-test-obj test-file)
+	(display #\; test-file)
+	(display ";" test-file)
+	(write write-test-obj test-file)
 	(newline test-file)
 	(write load-test-obj test-file)
 	(output-port? test-file)))
   (check-test-file "tmp3")
   (set! write-test-obj wto)
-  (set! display-test-obj dto)
   (set! load-test-obj lto)
   (let ((x (string->number "4195835.0"))
 	(y (string->number "3145727.0")))
@@ -707,13 +726,29 @@
   (test 0 modulo 2177452800 -86400)
   (test 0 modulo 2177452800 86400)
   (test 0 modulo -2177452800 -86400)
+  (test 0 modulo  0 -2177452800)
   (test #t 'remainder (tb 281474976710655325431 65535))
   (test #t 'remainder (tb 281474976710655325430 65535))
+
   (SECTION 6 5 8)
   (test 281474976710655325431 string->number "281474976710655325431")
   (test "281474976710655325431" number->string 281474976710655325431)
   (report-errs))
 
+(define (test-numeric-predicates)
+  (let* ((big-ex (expt 2 90))
+	 (big-inex (exact->inexact big-ex)))
+    (newline)
+    (display ";testing bignum-inexact comparisons;")
+    (newline)
+    (SECTION 6 5 5)
+    (test #f = (+ big-ex 1) big-inex (- big-ex 1))
+    (test #f = big-inex (+ big-ex 1) (- big-ex 1))
+    (test #t < (- (inexact->exact big-inex) 1)
+	  big-inex
+	  (+ (inexact->exact big-inex) 1))))
+
+
 (SECTION 6 5 9)
 (test "0" number->string 0)
 (test "100" number->string 100)
@@ -734,6 +769,10 @@
 (test #f string->number "3.3I")
 (test #f string->number "-")
 (test #f string->number "+")
+(test #t 'string->number (or (not (string->number "80000000" 16))
+			     (positive? (string->number "80000000" 16))))
+(test #t 'string->number (or (not (string->number "-80000000" 16))
+			     (negative? (string->number "-80000000" 16))))
 
 (SECTION 6 6)
 (test #t eqv? '#\  #\Space)
@@ -980,6 +1019,9 @@
 
 (test '(b e h) map cadr '((a b) (d e) (g h)))
 (test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '(1 2 3) map + '(1 2 3))
+(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)))
@@ -1097,21 +1139,23 @@
 	    (test #t eof-object? (read-char test-file))
 	    (input-port? test-file))))
   (test #\; read-char test-file)
-  (test display-test-obj read test-file)
+  (test #\; read-char test-file)
+  (test #\; read-char test-file)
+  (test write-test-obj read test-file)
   (test load-test-obj read test-file)
   (close-input-port test-file))
 (SECTION 6 10 3)
 (define write-test-obj
-  '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
-(define display-test-obj
-  '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
+  '(#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
 (define load-test-obj
   (list 'define 'foo (list 'quote write-test-obj)))
 (test #t call-with-output-file
       "tmp1"
       (lambda (test-file)
 	(write-char #\; test-file)
-	(display write-test-obj test-file)
+	(display #\; test-file)
+	(display ";" test-file)
+	(write write-test-obj test-file)
 	(newline test-file)
 	(write load-test-obj test-file)
 	(output-port? test-file)))
@@ -1119,7 +1163,9 @@
 
 (define test-file (open-output-file "tmp2"))
 (write-char #\; test-file)
-(display write-test-obj test-file)
+(display #\; test-file)
+(display ";" test-file)
+(write write-test-obj test-file)
 (newline test-file)
 (write load-test-obj test-file)
 (test #t output-port? test-file)
@@ -1145,13 +1191,18 @@
   (report-errs))
 
 (report-errs)
-(cond ((and (string->number "0.0") (inexact? (string->number "0.0")))
-       (test-inexact)
-       (test-inexact-printing)))
+(let ((have-inexacts? 
+       (and (string->number "0.0") (inexact? (string->number "0.0"))))
+      (have-bignums?
+       (let ((n (string->number "281474976710655325431")))
+	 (and n (exact? n)))))
+  (cond (have-inexacts?
+	 (test-inexact)
+	 (test-inexact-printing)))
+  (if have-bignums? (test-bignum))
+  (if (and have-inexacts? have-bignums?)
+      (test-numeric-predicates)))
 
-(let ((n (string->number "281474976710655325431")))
-  (if (and n (exact? n))
-      (test-bignum)))
 (newline)
 (display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
 (newline)