From cf94915abfb59f74f6e4852cd791e9e348f0e5ed Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sun, 8 Feb 2004 22:06:55 +0000
Subject: [PATCH] Fix various test problems exposed by clisp.

---
 ansi-tests/divide.lsp      | 13 +++----------
 ansi-tests/float.lsp       |  4 +++-
 ansi-tests/numbers-aux.lsp | 20 ++++++++++++++------
 ansi-tests/phase.lsp       | 11 +++++++----
 ansi-tests/rational.lsp    |  5 ++++-
 ansi-tests/rationalize.lsp |  5 ++++-
 ansi-tests/times.lsp       |  2 +-
 7 files changed, 36 insertions(+), 24 deletions(-)

diff --git a/ansi-tests/divide.lsp b/ansi-tests/divide.lsp
index a0d0b47b..ea142c71 100644
--- a/ansi-tests/divide.lsp
+++ b/ansi-tests/divide.lsp
@@ -115,12 +115,11 @@
 	for zero = (float 0.0 bound)
 	nconc
 	(loop for i = (1+ (random bound))
-	      for j = (1+ (random bound))
 	      for c = (complex i zero)
 	      for q = (/ c c)
 	      repeat 100
 	      unless (eql q (complex one zero))
-	      collect (list i j c q)))
+	      collect (list i c q (complex one zero))))
   nil)
 
 
@@ -176,12 +175,12 @@
 (deftest /.12
   (loop for type in '(short-float single-float double-float long-float)
 	for lower in (mapcar
-		     #'rational
+		     #'rational-safely
 		     (list
 		      least-positive-short-float least-positive-single-float
 		      least-positive-double-float least-positive-long-float))
 	for upper in (mapcar
-		     #'rational
+		     #'rational-safely
 		     (list
 		      most-positive-short-float most-positive-single-float
 		      most-positive-double-float most-positive-long-float))
@@ -205,9 +204,3 @@
 		(eql (/ frneg) frpos)))
 	 collect (list i rpos rneg (float rpos one) (float rneg one))))
   nil)
-
-
-	 
-	 
-
-	
\ No newline at end of file
diff --git a/ansi-tests/float.lsp b/ansi-tests/float.lsp
index 04fba84b..8f097df0 100644
--- a/ansi-tests/float.lsp
+++ b/ansi-tests/float.lsp
@@ -44,10 +44,12 @@
 
 (deftest float.6
   (loop for x in *reals*
-	unless (or (not (typep x 'short-float))
+	unless (handler-case
+		(or (not (typep x 'short-float))
 		   (let ((y (float x 0.0f0)))
 		     (and (typep y 'single-float)
 			  (= x y))))
+		(arithmetic-error () t))
 	collect x)
   nil)
   
diff --git a/ansi-tests/numbers-aux.lsp b/ansi-tests/numbers-aux.lsp
index 3fcc00c5..eb5c7199 100644
--- a/ansi-tests/numbers-aux.lsp
+++ b/ansi-tests/numbers-aux.lsp
@@ -240,9 +240,13 @@
 	nconc
 	(loop for y in *reals*
 	      when (numbers-are-compatible x y)
-	      unless (let ((m (max x y)))
-		       (and (>= m x) (>= m y)
-			    (or (= m x) (= m y))))
+	      unless
+	      (handler-case
+	       (let ((m (max x y)))
+		 (and (>= m x) (>= m y)
+		      (or (= m x) (= m y))))
+	       (floating-point-underflow () t)
+	       (floating-point-overflow () t))
 	      collect (list x y (max x y)))))
 
 (defun min.2-fn ()
@@ -250,9 +254,13 @@
 	nconc
 	(loop for y in *reals*
 	      when (numbers-are-compatible x y)
-	      unless (let ((m (min x y)))
-		       (and (<= m x) (<= m y)
-			    (or (= m x) (= m y))))
+	      unless
+	      (handler-case
+	       (let ((m (min x y)))
+		 (and (<= m x) (<= m y)
+		      (or (= m x) (= m y))))
+	       (floating-point-underflow () t)
+	       (floating-point-overflow () t))
 	      collect (list x y (min x y)))))
 
 (defun epsilon (number)
diff --git a/ansi-tests/phase.lsp b/ansi-tests/phase.lsp
index 21fa1a1b..0035eacd 100644
--- a/ansi-tests/phase.lsp
+++ b/ansi-tests/phase.lsp
@@ -82,22 +82,25 @@
   (let ((p1 (phase #c(1 1)))
 	(p2 (phase #c(1.0f0 1.0f0))))
     (and (eql p1 p2)
-	 (approx= p1 (coerce (/ pi 4) 'single-float))))
+	 (approx= p1 (coerce (/ pi 4) 'single-float)
+		  (* 2 single-float-epsilon))))
   t)
 
 (deftest phase.15
   (let ((p (phase #c(1.0d0 1.0d0))))
-    (approx= p (coerce (/ pi 4) 'double-float)))
+    (approx= p (coerce (/ pi 4) 'double-float)
+	     (* 2 double-float-epsilon)))
   t)
 
 (deftest phase.16
   (let ((p (phase #c(1.0s0 1.0s0))))
-    (approx= p (coerce (/ pi 4) 'single-float)))
+    (approx= p (coerce (/ pi 4) 'single-float)
+	     (* 2 short-float-epsilon)))
   t)
 
 (deftest phase.17
   (let ((p (phase #c(1.0l0 1.0l0))))
-    (approx= p (/ pi 4)))
+    (approx= p (/ pi 4) (* 2 long-float-epsilon)))
   t)
 
 ;;; Negative zeros
diff --git a/ansi-tests/rational.lsp b/ansi-tests/rational.lsp
index ee6e9590..0c1082a6 100644
--- a/ansi-tests/rational.lsp
+++ b/ansi-tests/rational.lsp
@@ -25,7 +25,10 @@
   nil)
 
 (deftest rational.1
-  (loop for x in *reals*
+  (loop for x in (loop for r in *reals*
+		       when (or (not (floatp r))
+				(<= -1000 (nth-value 1 (integer-decode-float r)) 1000))
+		       collect r)
 	for r = (rational x)
 	unless (and (rationalp r)
 		    (if (floatp x)
diff --git a/ansi-tests/rationalize.lsp b/ansi-tests/rationalize.lsp
index 5c003782..8bd92c8f 100644
--- a/ansi-tests/rationalize.lsp
+++ b/ansi-tests/rationalize.lsp
@@ -25,7 +25,10 @@
   nil)
 
 (deftest rationalize.1
-  (loop for x in *reals*
+  (loop for x in (loop for r in *reals*
+		       when (or (not (floatp r))
+				(<= -1000 (nth-value 1 (integer-decode-float r)) 1000))
+		       collect r)
 	for r = (rationalize x)
 	unless (and (rationalp r)
 		    (if (floatp x)
diff --git a/ansi-tests/times.lsp b/ansi-tests/times.lsp
index dd648704..942f0364 100644
--- a/ansi-tests/times.lsp
+++ b/ansi-tests/times.lsp
@@ -356,7 +356,7 @@
 	 unless (and (eql prod (complex (coerce (- 1 (* i j)) type)
 					(coerce (+ i j) type)))
 		     (eql prod (* cy cx)))
-	 collect (list i j x y (* cx cy))))
+	 collect (list type i j x y (* cx cy))))
   nil)
 
 (deftest times.order.1
-- 
GitLab