From cdd3462e9f117be8a33a384eef00c9deb791d27e Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Mon, 2 Nov 1998 13:44:34 +0000
Subject: [PATCH] * Re-work not-more-contagious to return True for a wider
 range of valid types.

* Restrict the (+ x 0) transform to rationals, because (+ -0.0 0) is
0.0, not -0.0.
---
 compiler/srctran.lisp | 109 ++++++++++++++++++++++--------------------
 1 file changed, 58 insertions(+), 51 deletions(-)

diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index aaf39d6bf..20b3d6225 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.88 1998/10/03 05:18:15 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.89 1998/11/02 13:44:34 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -365,17 +365,6 @@
 ;;; 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)
@@ -3005,51 +2994,59 @@
   "convert (* x 0) to 0."
   0)
 
-
-;;; NOT-MORE-CONTAGIOUS  --  Interface
-;;;
-;;;    Return T if in an arithmetic op including continuations X and Y, the
-;;; result type is not affected by the type of X.  That is, Y is at least as
-;;; contagious as X.
-;;;
-#+nil
-(defun not-more-contagious (x y)
-  (declare (type continuation x y))
-  (let ((x (continuation-type x))
-	(y (continuation-type y)))
-    (values (type= (numeric-contagion x y)
-		   (numeric-contagion y y)))))
+;;; Not-More-Contagious  --  Interface
 ;;;
-;;; Patched version by Raymond Toy. dtc: Should be safer although it
-;;; needs more work as valid transforms are missed; some cases are
-;;; specific to particular transform functions so the use of this
-;;; function may need a re-think.
+;;;    Return T if in an arithmetic OP including continuations X and
+;;; Y, the result type is not affected by the type of X. The main
+;;; checks performed here are that the type of X does not cause a
+;;; change in the float format of the result, or change the result to
+;;; a complex float. It is assumed that the caller considers the
+;;; affect of X on Value of the result. Thus with rational
+;;; canonicalisation, X is permitted to be a rational or complex
+;;; rational even if Y is only an integer or complex integer assuming
+;;; that the result will be canonacilisted to the correct type.
 ;;;
 (defun not-more-contagious (x y)
   (declare (type continuation x y))
-  (flet ((simple-numeric-type (num)
-	   (and (numeric-type-p num)
-		;; Return non-NIL if NUM is integer, rational, or a float
-		;; of some type (but not FLOAT)
-		(case (numeric-type-class num)
-		  ((integer rational)
-		   t)
-		  (float
-		   (numeric-type-format num))
-		  (t
-		   nil)))))
-    (let ((x (continuation-type x))
-	  (y (continuation-type y)))
-      (if (and (simple-numeric-type x)
-	       (simple-numeric-type y))
-	  (values (type= (numeric-contagion x y)
-			 (numeric-contagion y y)))))))
+  (let ((type1 (continuation-type x))
+	(type2 (continuation-type y)))
+    (if (and (numeric-type-p type1) (numeric-type-p type2))
+	(let ((class1 (numeric-type-class type1))
+	      (class2 (numeric-type-class type2))
+	      (format1 (numeric-type-format type1))
+	      (format2 (numeric-type-format type2))
+	      (complexp1 (numeric-type-complexp type1))
+	      (complexp2 (numeric-type-complexp type2)))
+	  (cond ((or (null complexp1) (null class1)) Nil)
+		((member class1 '(integer rational)) 'T)
+		((and (eq class1 'float) (null complexp2)) Nil)
+		((and (eq class1 'float) (null class2)) Nil)
+		((and (eq class1 'float) (eq class2 'float))
+		 (and (ecase complexp2
+			(:real (eq complexp1 :real))
+			(:complex 'T))
+		      (ecase format2
+			((nil short-float single-float)
+			 (member format1 '(short-float single-float)))
+			#-long-float
+			((double-float long-float) 'T)
+			#+long-float
+			(double-float
+			 (member format1 '(short-float single-float
+					   double-float)))
+			#+long-float
+			(long-float 'T))))
+		((and (eq class1 'float) (member class2 '(integer rational)))
+		 Nil)
+		(t
+		 (error "Unexpected types: ~s ~s~%" type1 type2)))))))
 
 ;;; Fold (+ x 0).
 ;;;
-;;;    If y is not constant, not zerop, or is contagious, or a
-;;; positive float +0.0 then give up.
+;;;    If y is not constant, not zerop, or is contagious, or a positive
+;;; float +0.0 then give up because (+ -0.0 0.0) is 0.0 not -0.0.
 ;;;
+#+nil
 (deftransform + ((x y) (t (constant-argument t)) * :when :both)
   "fold zero arg"
   (let ((val (continuation-value y)))
@@ -3059,10 +3056,20 @@
       (give-up)))
   'x)
 
+;;; Fold (+ x 0).
+;;;
+;;; Restricted to rationals, because (+ -0.0 0) is 0.0, not -0.0.
+;;;
+(deftransform + ((x y) (rational (constant-argument (member 0))) *
+		 :when :both)
+  "fold zero arg"
+  'x)
+
+
 ;;; Fold (- x 0).
 ;;;
-;;;    If y is not constant, not zerop, or is contagious, or a
-;;; negative float -0.0 then give up.
+;;;    If y is not constant, not zerop, or is contagious, or a negative
+;;; float -0.0 then give up because (- -0.0 -0.0) is 0.0, not -0.0.
 ;;;
 (deftransform - ((x y) (t (constant-argument t)) * :when :both)
   "fold zero arg"
-- 
GitLab