From d82637b8e804ba11909fe259af47938dd0793578 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Thu, 1 Oct 1998 16:01:48 +0000
Subject: [PATCH] Few fixes to elfun-derive-type-simple and associated interval
 functions, from Raymond Toy.

---
 compiler/float-tran.lisp | 15 +++++++++++--
 compiler/srctran.lisp    | 46 +++++++++++++++++++++++++++++++++-------
 2 files changed, 51 insertions(+), 10 deletions(-)

diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index 476d88854..641e27b06 100644
--- a/compiler/float-tran.lisp
+++ b/compiler/float-tran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.76 1998/09/29 13:16:28 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.77 1998/10/01 16:01:48 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -575,6 +575,16 @@
 ;;;; function, based on the domain of the input.
 ;;;;
 
+;;; Generate a specifier for a complex type specialized to the same
+;;; type as the argument.
+(defun complex-float-type (arg)
+  (declare (type numeric-type arg))
+  (let* ((format (case (numeric-type-class arg)
+		   ((integer rational) 'single-float)
+		   (t (numeric-type-format arg))))
+	 (float-type (or format 'float)))
+    (specifier-type `(complex ,float-type))))
+
 ;;; Compute a specifier like '(or float (complex float)), except float
 ;;; should be the right kind of float.  Allow bounds for the float
 ;;; part too.
@@ -698,7 +708,8 @@
 		       (list result-type
 			     (specifier-type `(complex ,bound-type))))))
 		(t
-		 (float-or-complex-float-type arg)))))
+		 ;; No intersection so the result must be purely complex.
+		 (complex-float-type arg)))))
 	   (t
 	    (float-or-complex-float-type arg default-low default-high))))))
 
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index f49a55587..a40d48310 100644
--- a/compiler/srctran.lisp
+++ b/compiler/srctran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.86 1998/09/20 15:16:14 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.87 1998/10/01 16:01:47 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -388,6 +388,35 @@
     ('both
      (and (interval-low x) (interval-high x)))))
 
+;;; Signed zero comparison functions.  Use these functions if we need
+;;; to distinguish between signed zeroes.
+
+(defun signed-zero-< (x y)
+  (declare (real x y))
+  (or (< x y)
+      (and (= x y)
+	   (< (float-sign (float x))
+	      (float-sign (float y))))))
+(defun signed-zero-> (x y)
+  (declare (real x y))
+  (or (> x y)
+      (and (= x y)
+	   (> (float-sign (float x))
+	      (float-sign (float y))))))
+
+(defun signed-zero-= (x y)
+  (declare (real x y))
+  (and (= x y)
+       (= (float-sign (float x))
+	  (float-sign (float y)))))
+
+(defun signed-zero-<= (x y)
+  (declare (real x y))
+  (or (< x y)
+      (and (= x y)
+	   (<= (float-sign (float x))
+	       (float-sign (float y))))))
+
 ;;; INTERVAL-CONTAINS-P
 ;;;
 ;;; See if the interval X contains the number P, taking into account
@@ -402,25 +431,26 @@
 	(hi (interval-high x)))
     (cond ((and lo hi)
 	   ;; The interval is bounded
-	   (if (<= (bound-value lo) p (bound-value hi))
+	   (if (and (signed-zero-<= (bound-value lo) p)
+		    (signed-zero-<= p (bound-value hi)))
 	       ;; P is definitely in the closure of the interval.
 	       ;; We just need to check the end points now.
-	       (cond ((= p (bound-value lo))
+	       (cond ((signed-zero-= p (bound-value lo))
 		      (numberp lo))
-		     ((= p (bound-value hi))
+		     ((signed-zero-= p (bound-value hi))
 		      (numberp hi))
 		     (t t))
 	       nil))
 	  (hi
 	   ;; Interval with upper bound
-	   (if (< p (bound-value hi))
+	   (if (signed-zero-< p (bound-value hi))
 	       t
-	       (and (numberp hi) (= p hi))))
+	       (and (numberp hi) (signed-zero-= p hi))))
 	  (lo
 	   ;; Interval with lower bound
-	   (if (> p (bound-value lo))
+	   (if (signed-zero-> p (bound-value lo))
 	       t
-	       (and (numberp lo) (= p lo))))
+	       (and (numberp lo) (signed-zero-= p lo))))
 	  (t
 	   ;; Interval with no bounds
 	   t))))
-- 
GitLab