From 9dfc672dd7d301041c8193f2276b415ccfed8a9c Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sat, 23 Aug 2003 13:42:35 +0000
Subject: [PATCH] Fixed test lossage revealed by ACL when trying to compare
 integers or rationals that are out of the range of valid values of a float
 type.

---
 ansi-tests/number-comparison.lsp | 55 +++++++++++++++++++++--
 ansi-tests/numbers-aux.lsp       | 76 ++++++++++++++++++++++++--------
 2 files changed, 109 insertions(+), 22 deletions(-)

diff --git a/ansi-tests/number-comparison.lsp b/ansi-tests/number-comparison.lsp
index 95355568..87a9e40e 100644
--- a/ansi-tests/number-comparison.lsp
+++ b/ansi-tests/number-comparison.lsp
@@ -378,13 +378,20 @@
 				    most-positive-single-float
 				    most-positive-double-float
 				    most-positive-long-float)
+		 for lower-bound in (list most-negative-short-float
+				    most-negative-single-float
+				    most-negative-double-float
+				    most-negative-long-float)
 		 for one in '(1.0s0 1.0f0 1.0d0 1.0l0)
-		 when (<= x bound)
+		 when (if (floatp x) (subtypep (class-of x) (class-of bound))
+			(<= (rationalize lower-bound)
+			  x (rationalize bound)))
 		 nconc
 		 (let* ((y (float x one))
 			(z (* y (- one (* 2 epsilon)))))
 		   (list (list y z nil)
 			 (list z y t)))))
+     
      (loop for x in *universe*
 	   when (and (realp x) (<= x -1))
 	   nconc
@@ -396,8 +403,13 @@
 				    most-negative-single-float
 				    most-negative-double-float
 				    most-negative-long-float)
+		 for upper-bound in (list most-positive-short-float
+				    most-positive-single-float
+				    most-positive-double-float
+				    most-positive-long-float)
 		 for one in '(1.0s0 1.0f0 1.0d0 1.0l0)
-		 when (>= x bound)
+		 when (if (floatp x) (subtypep (class-of x) (class-of bound))
+			(<= (rationalize bound) x (rationalize upper-bound)))
 		 nconc
 		 (let* ((y (float x one))
 			(z (* y (- one (* 2 epsilon)))))
@@ -410,7 +422,19 @@
 				      single-float-epsilon
 				      double-float-epsilon
 				      long-float-epsilon)
+		 for lower-bound in (list most-negative-short-float
+				    most-negative-single-float
+				    most-negative-double-float
+				    most-negative-long-float)
+		 for upper-bound in (list most-positive-short-float
+				    most-positive-single-float
+				    most-positive-double-float
+				    most-positive-long-float)
 		 for one in '(1.0s0 1.0f0 1.0d0 1.0l0)
+		 when (if (floatp x) (subtypep (class-of x)
+					       (class-of lower-bound))
+			(<= (rationalize lower-bound)
+			    x (rationalize upper-bound)))
 		 nconc
 		 (let* ((y (float x one))
 			(z1 (+ y epsilon))
@@ -554,8 +578,14 @@
 				    most-positive-single-float
 				    most-positive-double-float
 				    most-positive-long-float)
+		 for lower-bound in (list most-negative-short-float
+				    most-negative-single-float
+				    most-negative-double-float
+				    most-negative-long-float)
 		 for one in '(1.0s0 1.0f0 1.0d0 1.0l0)
-		 when (<= x bound)
+		 when (if (floatp x) (subtypep (class-of x)
+					       (class-of lower-bound))
+			(<= (rationalize lower-bound) x (rationalize bound)))
 		 nconc
 		 (let* ((y (float x one))
 			(z (* y (- one (* 2 epsilon)))))
@@ -572,8 +602,13 @@
 				    most-negative-single-float
 				    most-negative-double-float
 				    most-negative-long-float)
+		 for upper-bound in (list most-positive-short-float
+				    most-positive-single-float
+				    most-positive-double-float
+				    most-positive-long-float)
 		 for one in '(1.0s0 1.0f0 1.0d0 1.0l0)
-		 when (>= x bound)
+		 when (if (floatp x) (subtypep (class-of x) (class-of bound))
+			(<= (rationalize bound) x (rationalize upper-bound)))
 		 nconc
 		 (let* ((y (float x one))
 			(z (* y (- one (* 2 epsilon)))))
@@ -586,7 +621,19 @@
 				      single-float-epsilon
 				      double-float-epsilon
 				      long-float-epsilon)
+		 for lower-bound in (list most-negative-short-float
+				    most-negative-single-float
+				    most-negative-double-float
+				    most-negative-long-float)
+		 for upper-bound in (list most-positive-short-float
+				    most-positive-single-float
+				    most-positive-double-float
+				    most-positive-long-float)
 		 for one in '(1.0s0 1.0f0 1.0d0 1.0l0)
+		 when (if (floatp x) (subtypep (class-of x)
+					       (class-of lower-bound))
+			(<= (rationalize lower-bound)
+			    x (rationalize upper-bound)))
 		 nconc
 		 (let* ((y (float x one))
 			(z1 (+ y epsilon))
diff --git a/ansi-tests/numbers-aux.lsp b/ansi-tests/numbers-aux.lsp
index b19fb793..f9e00ef6 100644
--- a/ansi-tests/numbers-aux.lsp
+++ b/ansi-tests/numbers-aux.lsp
@@ -5,82 +5,122 @@
 
 (in-package :cl-test)
 
+(defun numbers-are-compatible (x y)
+  (cond
+   ((complexp x)
+    (and (numbers-are-compatible (realpart x) y)
+	 (numbers-are-compatible (imagpart x) y)))
+   ((complexp y)
+    (and (numbers-are-compatible x (realpart y))
+	 (numbers-are-compatible x (imagpart y))))
+   (t
+    (when (floatp x) (rotatef x y))
+    (or (floatp x)
+	(not (floatp y))
+	(etypecase y
+	  (short-float
+	   (<= #.(rationalize most-negative-short-float)
+	       x
+	       #.(rationalize most-positive-short-float)))
+	  (single-float
+	   (<= #.(rationalize most-negative-single-float)
+	       x
+	       #.(rationalize most-positive-single-float)))
+	  (double-float
+	   (<= #.(rationalize most-negative-double-float)
+	       x
+	       #.(rationalize most-positive-double-float)))
+	  (long-float
+	   (<= #.(rationalize most-negative-long-float)
+	       x
+	       #.(rationalize most-positive-long-float))))))))    
+
 (defun =.4-fn ()
   (loop for x in *numbers*
 	append
 	(loop for y in *numbers*
-	      unless (if (= x y) (= y x) (not (= y x)))
+	      unless (or (not (numbers-are-compatible x y))
+			 (if (= x y) (= y x) (not (= y x))))
 	      collect (list x y))))
 
 (defun /=.4-fn ()
   (loop for x in *numbers*
 	append
 	(loop for y in *numbers*
-	      unless (if (/= x y) (/= y x) (not (/= y x)))
+	      unless (or (not (numbers-are-compatible x y))
+			 (if (/= x y) (/= y x) (not (/= y x))))
 	      collect (list x y))))
 
 (defun /=.4a-fn ()
   (loop for x in *numbers*
 	append
 	(loop for y in *numbers*
-	      when (if (= x y)
-		       (/= x y)
-		     (not (/= x y)))
+	      when (and (numbers-are-compatible x y)
+			(if (= x y)
+			    (/= x y)
+			  (not (/= x y))))
 	      collect (list x y))))
 
 (defun <.8-fn ()
   (loop for x in *reals*
 	nconc
 	(loop for y in *reals*
-	      when (and (< x y) (> x y))
+	      when (and (numbers-are-compatible x y)
+			(and (< x y) (> x y)))
 	      collect (list x y))))
 
 (defun <.9-fn ()
   (loop for x in *reals*
 	nconc
 	(loop for y in *reals*
-	      when (if (< x y) (not (> y x))
-		     (> y x))
+	      when (and (numbers-are-compatible x y)
+			(if (< x y) (not (> y x))
+			  (> y x)))
 	      collect (list x y))))
 
 (defun <.10-fn ()
   (loop for x in *reals*
 	nconc
 	(loop for y in *reals*
-	      when (if (< x y) (>= x y)
-		     (not (>= x y)))
+	      when (and (numbers-are-compatible x y)
+			(if (< x y) (>= x y)
+			  (not (>= x y))))
 	      collect (list x y))))
 
 (defun <=.8-fn ()
   (loop for x in *reals*
 	nconc
 	(loop for y in *reals*
-	      when (if (<= x y) (not (>= y x))
-		     (>= y x))
+	      when (and (numbers-are-compatible x y)
+			(if (<= x y) (not (>= y x))
+			  (>= y x)))
 	      collect (list x y))))
  
 (defun <=.9-fn ()
   (loop for x in *reals*
 	nconc
 	(loop for y in *reals*
-	      when (if (<= x y) (not (or (= x y) (< x y)))
-		     (or (= x y) (< x y)))
+	      when (and (numbers-are-compatible x y)
+			(if (<= x y) (not (or (= x y) (< x y)))
+			  (or (= x y) (< x y))))
 	      collect (list x y))))
 
 (defun >.8-fn ()
   (loop for x in *reals*
 	nconc
 	(loop for y in *reals*
-	      when (if (> x y) (<= x y)
-		     (not (<= x y)))
+	      when (and (numbers-are-compatible x y)
+			(if (> x y) (<= x y)
+			  (not (<= x y))))
 	      collect (list x y))))
 
 (defun >=.8-fn ()
   (loop for x in *reals*
 	nconc
 	(loop for y in *reals*
-	      when (if (>= x y) (not (or (= x y) (> x y)))
-		     (or (= x y) (> x y)))
+	      when (and (numbers-are-compatible x y)
+			(if (>= x y) (not (or (= x y) (> x y)))
+			  (or (= x y) (> x y))))
 	      collect (list x y))))
 
 ;;; Comparison of rationsls
-- 
GitLab