From fb5ea66036a77b5c2883914c5f3774f48ebcaabc Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sat, 3 Oct 1998 05:18:15 +0000
Subject: [PATCH] From Raymond Toy: o  Fix bugs in
 interval-intersection/difference, and some cleanup of    unused stuff. o 
 Make interval-intersect-p use interval-intersection/difference. o  Added
 signed-interval->=, and make interval-range-info use it    instead of it's
 own version.

---
 compiler/srctran.lisp | 79 ++++++++++++++++++-------------------------
 1 file changed, 33 insertions(+), 46 deletions(-)

diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index a40d48310..aaf39d6bf 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.87 1998/10/01 16:01:47 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.88 1998/10/03 05:18:15 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -353,11 +353,29 @@
   (make-interval :low (bound-value (interval-low x))
 		 :high (bound-value (interval-high x))))
 
+(defun signed-zero->= (x y)
+  (declare (real x y))
+  (or (> x y)
+      (and (= x y)
+	   (>= (float-sign (float x))
+	       (float-sign (float y))))))
+
 ;;; INTERVAL-RANGE-INFO
 ;;;
 ;;; For an interval X, if X >= POINT, return '+.  If X <= POINT, return
 ;;; '-. Otherwise return NIL.
 ;;;
+#+nil
+(defun interval-range-info (x &optional (point 0))
+  (declare (type interval x))
+  (let ((lo (interval-low x))
+	(hi (interval-high x)))
+    (cond ((and lo (signed-zero->= (bound-value lo) point))
+	   '+)
+	  ((and hi (signed-zero->= point (bound-value hi)))
+	   '-)
+	  (t
+	   nil))))
 (defun interval-range-info (x &optional (point 0))
   (declare (type interval x))
   (labels ((signed->= (x y)
@@ -468,41 +486,15 @@
 ;;;
 (defun interval-intersect-p (x y &optional closed-intervals-p)
   (declare (type interval x y))
-  (let ((x-lo (interval-low x))
-	(x-hi (interval-high x))
-	(y-lo (interval-low y))
-	(y-hi (interval-high y)))
-    (labels ((test-number (p int)
-	       ;; Test if P is in the interval.
-	       (when (interval-contains-p (bound-value p)
-					  (interval-closure int))
-		 (let ((lo (interval-low int))
-		       (hi (interval-high int)))
-		   ;; Check for endpoints
-		   (cond ((or (null lo) (null hi))
-			  t)
-			 ((= (bound-value p) (bound-value lo))
-			  (or closed-intervals-p
-			      (not (and (consp p) (numberp lo)))))
-			 ((= (bound-value p) (bound-value hi))
-			  (or closed-intervals-p
-			      (not (and (numberp p) (consp hi)))))
-			 (t t)))))
-	     (test-lower-bound (p int)
-	       ;; P is a lower bound of an interval.
-	       (if p
-		   (test-number p int)
-		   (not (interval-bounded-p int 'below))))
-	     (test-upper-bound (p int)
-	       ;; P is an upper bound of an interval
-	       (if p
-		   (test-number p int)
-		   (not (interval-bounded-p int 'above))))
-	     )
-      (or (test-lower-bound x-lo y)
-	  (test-upper-bound x-hi y)
-	  (test-lower-bound y-lo x)
-	  (test-upper-bound y-hi x)))))
+  (multiple-value-bind (intersect diff)
+      (interval-intersection/difference (if closed-intervals-p
+					    (interval-closure x)
+					    x)
+					(if closed-intervals-p
+					    (interval-closure y)
+					    y))
+    (declare (ignore diff))
+    intersect))
 
 ;;; Are the two intervals adjacent?  That is, is there a number
 ;;; between the two intervals that is not an element of either
@@ -538,8 +530,7 @@
 ;;;
 (defun interval-intersection/difference (x y)
   (declare (type interval x y))
-  (let ((closed-intervals-p nil)
-	(x-lo (interval-low x))
+  (let ((x-lo (interval-low x))
 	(x-hi (interval-high x))
 	(y-lo (interval-low y))
 	(y-hi (interval-high y)))
@@ -557,14 +548,10 @@
 	     (let ((lo (interval-low int))
 		   (hi (interval-high int)))
 	       ;; Check for endpoints
-	       (cond ((or (null lo) (null hi))
-		      t)
-		     ((= (bound-value p) (bound-value lo))
-		      (or closed-intervals-p
-			  (not (and (consp p) (numberp lo)))))
-		     ((= (bound-value p) (bound-value hi))
-		      (or closed-intervals-p
-			  (not (and (numberp p) (consp hi)))))
+	       (cond ((and lo (= (bound-value p) (bound-value lo)))
+		      (not (and (consp p) (numberp lo))))
+		     ((and hi (= (bound-value p) (bound-value hi)))
+		      (not (and (numberp p) (consp hi))))
 		     (t t)))))
 	 (test-lower-bound (p int)
 	   ;; P is a lower bound of an interval.
-- 
GitLab