From 1a0a7672ea3283e655fd6161c1670ce731cfe89c Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sun, 14 Dec 1997 14:10:27 +0000
Subject: [PATCH] Merge in the revised derive-type optimisers from Raymond Toy:

compiler/srctran.lisp

o  Replaced all of the old optimizer routines with new ones that should
work much better.  Optimizers should now handle all union types and most
member types.  NOTE:  for some reason a member type with both numbers
and non-numbers isn't quite handled correctly.  The optimizer is only
passed the elements of the member type that are numbers; it never sees
the non-number elements of the member type.

o  Fixed a bug in bound-func.  Since all of the FP traps are turned off,
we now need to check in case the function returns things like infinity
and convert them to nil.

o  Fixed a bug in the computation of bounds for rem.  Invalid intervals
were sometimes returned.

compiler/float-tran.lisp

o  Mods to handle the changes in srctran.lisp.

o  All of the optimizers (from propagate-float and propagate-fun) should
now handle union types and member types.

o  Fixed a bug in the atan optimizer for two args with at least one of
them not being a real.

o  For functions that return (or float (complex float)), we try to be
more careful and compute the bounds for the float part, since we usually
have them.  Not sure what we gain, though.

-=-=-=-

Plus some further cleanups and fixes by Douglas Crosher:

o Merge with the latest verion of float-trans: CIS transform; no
result types on complex function transforms.

o Can use a common scale-float-derive-type-aux function.

o complex-derive-type-aux-2 was broken, needed updating to handle
changes.

o For sqrt and log return an (or float complex) type if the argument
type includes 0.0 in its range as 0.0 = -0.0 so the argument may also
be -0.0.

o A number of the optimizers returned a complex float with invalid
intervals just copied from the argument - strip the intervals from the
returned type in these cases.

o Note no expt optimiser.
---
 compiler/float-tran.lisp | 822 +++++++++++++++++---------------------
 compiler/srctran.lisp    | 840 +++++++++++++++++++--------------------
 2 files changed, 757 insertions(+), 905 deletions(-)

diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index b68444ba6..ad6cecfc9 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.47 1997/12/12 15:19:03 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.48 1997/12/14 14:10:27 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -249,40 +249,40 @@
 
 #+propagate-float-type
 (progn
-(macrolet
-    ((frob (name)
-       `(defoptimizer (,name derive-type) ((f ex))
-	 (flet ((scale-bound (x n)
-		  ;; We need to be a bit careful here and catch any
-		  ;; overflows that might occur.  We can ignore
-		  ;; underflows which become zeros.
-		  (set-bound
-		   (handler-case
-		       (scale-float (bound-value x) n)
-		     (floating-point-overflow ()
-		       nil))
-		   (consp x))))
-	   (let ((f-type (continuation-type f))
-		 (ex-type (continuation-type ex)))
-	     (when (and (numeric-type-p f-type)
-			(numeric-type-p ex-type))
-	       (let ((f-lo (numeric-type-low f-type))
-		     (f-hi (numeric-type-high f-type))
-		     (ex-lo (numeric-type-low ex-type))
-		     (ex-hi (numeric-type-high ex-type))
-		     (new-lo nil)
-		     (new-hi nil))
-		 (when (and f-hi ex-hi)
-		   (setf new-hi (scale-bound f-hi ex-hi)))
-		 (when (and f-lo ex-lo)
-		   (setf new-lo (scale-bound f-lo ex-lo)))
-		 (make-numeric-type :class (numeric-type-class f-type)
-				    :format (numeric-type-format f-type)
-				    :complexp :real
-				    :low new-lo
-				    :high new-hi))))))))
-  (frob scale-single-float)
-  (frob scale-double-float))
+
+(defun scale-float-derive-type-aux (f ex same-arg)
+  (declare (ignore same-arg))
+  (flet ((scale-bound (x n)
+	   ;; We need to be a bit careful here and catch any overflows
+	   ;; that might occur.  We can ignore underflows which become
+	   ;; zeros.
+	   (set-bound
+	    (handler-case
+	     (scale-float (bound-value x) n)
+	     (floating-point-overflow ()
+		nil))
+	    (consp x))))
+    (when (and (numeric-type-p f) (numeric-type-p ex))
+      (let ((f-lo (numeric-type-low f))
+	    (f-hi (numeric-type-high f))
+	    (ex-lo (numeric-type-low ex))
+	    (ex-hi (numeric-type-high ex))
+	    (new-lo nil)
+	    (new-hi nil))
+	(when (and f-hi ex-hi)
+	  (setf new-hi (scale-bound f-hi ex-hi)))
+	(when (and f-lo ex-lo)
+	  (setf new-lo (scale-bound f-lo ex-lo)))
+	(make-numeric-type :class (numeric-type-class f)
+			   :format (numeric-type-format f)
+			   :complexp :real
+			   :low new-lo
+			   :high new-hi)))))
+;;;
+(defoptimizer (scale-single-float derive-type) ((f ex))
+  (two-arg-derive-type f ex #'scale-float-derive-type-aux))
+(defoptimizer (scale-double-float derive-type) ((f ex))
+  (two-arg-derive-type f ex #'scale-float-derive-type-aux))
 	     
 ;;; toy@rtp.ericsson.se:
 ;;;
@@ -291,24 +291,25 @@
 ;;; defined range.  Quite useful if we want to convert some type of
 ;;; bounded integer into a float.
 
-(macrolet ((frob (fun type)
-	     `(defoptimizer (,fun derive-type) ((num))
-	       (let ((num-type (continuation-type num)))
-		 (if (or (numeric-type-p num-type)
-			   (union-type-p num-type))
-		     (elfun-derive-type-union
-		      num-type
-		      (constantly t)
-		      #'(lambda (lo hi)
-			  ;; When converting a number to a float, the
-			  ;; limits on the resulting float are obviously
-			  ;; the same as the original number.
-			  (values lo hi ',type))
-		      (specifier-type ',type))
-		     *universal-type*)))))
+(macrolet
+    ((frob (fun type)
+       (let ((aux-name (concatenate 'string (string fun) "-DERIVE-TYPE-AUX")))
+	 `(progn
+	   (defun ,(intern aux-name) (num)
+	     ;; When converting a number to a float, the limits are
+	     ;; the same.
+	     (let* ((lo (bound-func #'(lambda (x)
+					(coerce x ',type))
+				    (numeric-type-low num)))
+		    (hi (bound-func #'(lambda (x)
+					(coerce x ',type))
+				    (numeric-type-high num))))
+	       (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
+	   
+	   (defoptimizer (,fun derive-type) ((num))
+	     (one-arg-derive-type num #',(intern aux-name)))))))
   (frob %single-float single-float)
   (frob %double-float double-float))
-
 ) ; end progn  
 
 
@@ -582,64 +583,6 @@
 			          ,(or hi '*))
 			 (complex ,f-type)))))
 
-(defun elfun-derive-type-1 (num cond limit-fun default-type)
-  (declare (type numeric-type num))
-  (cond ((eq (numeric-type-complexp num) :complex)
-	 ;; If the argument is complex, we return a complex, without
-	 ;; bounds.
-	 (make-numeric-type :class (numeric-type-class num)
-			    :format (numeric-type-format num)
-			    :complexp :complex))
-	((and (numeric-type-real-p num)
-	      (funcall cond (numeric-type-low num) (numeric-type-high num)))
-	 (with-float-traps-masked (:underflow :overflow)
-	   ;; The call to the limit-fun has (most) traps disabled.  It
-	   ;; can naively compute the result and return infinity for
-	   ;; the value.  We convert the infinity to nil as needed.
-	   (multiple-value-bind (lo-lim hi-lim float-type)
-	       (funcall limit-fun
-			(numeric-type-low num)
-			(numeric-type-high num))
-	     (make-numeric-type :class 'float
-				:format (or float-type
-					    (elfun-float-format
-					     (numeric-type-format num)))
-				:complexp :real
-				:low (if (and (floatp lo-lim)
-					      (float-infinity-p lo-lim))
-					 nil
-					 lo-lim)
-				:high (if (and (floatp hi-lim)
-					       (float-infinity-p hi-lim))
-					  nil
-					  hi-lim)))))
-	(default-type
-	    default-type)
-	(t
-	 (float-or-complex-type num))))
-
-;;; Same as ELFUN-DERIVE-TYPE-1 except we can handle simple
-;;; NUMERIC-TYPEs and UNION-TYPEs.
-(defun elfun-derive-type-union
-    (type cond limit-fun
-	  &optional default-type)
-  (cond ((union-type-p type)
-	 ;; For a UNION-TYPE, run down the list of unions and derive
-	 ;; the resulting type of each union and make a UNION-TYPE of
-	 ;; the results.
-	 (let ((result '()))
-	   (dolist (interval (union-type-types type))
-	     (let ((derived-type (elfun-derive-type-1 interval cond limit-fun default-type)))
-	       (if (union-type-p derived-type)
-		   ;; Insert union types in to the result
-		   (dolist (item (union-type-types derived-type))
-		     (push item result))
-		   (push derived-type result))))
-	   (make-union-type (derive-merged-union-types result))))
-	((numeric-type-p type)
-	 (elfun-derive-type-1 type cond limit-fun default-type))
-	(t
-	 (specifier-type 'number))))
 )  ; end progn
 
 #+propagate-fun-type
@@ -652,22 +595,40 @@
 
 ;;; Handle these monotonic increasing functions whose domain is
 ;;; possibly part of the real line
-(macrolet ((frob (name cond def-lo-bnd def-hi-bnd)
-	     (let ((num (gensym))
-		   (lo-bnd (gensym))
-		   (hi-bnd (gensym)))
-	       `(defoptimizer (,name derive-type) ((,num))
-		 (elfun-derive-type-union
-		  (continuation-type ,num)
-		  ,cond
-		  #'(lambda (,lo-bnd ,hi-bnd)
-		      ;; Since the function is monotonic increasing, the
-		      ;; lower bound and the upper bound are the values
-		      ;; of the function at the bounds of the input
-		      ;; range.
-		      (values (or (bound-func #',name ,lo-bnd) ,def-lo-bnd)
-			      (or (bound-func #',name ,hi-bnd) ,def-hi-bnd))))))))
 
+(defun elfun-derive-type-simple (arg fcn cond default-lo default-hi)
+  (etypecase arg
+    (numeric-type
+     (cond ((eq (numeric-type-complexp arg) :complex)
+	    (make-numeric-type :class (numeric-type-class arg)
+			       :format (numeric-type-format arg)
+			       :complexp :complex
+			       :low nil
+			       :high nil))
+	   ((numeric-type-real-p arg)
+	    (let ((lo (numeric-type-low arg))
+		  (hi (numeric-type-high arg)))
+	      (if (funcall cond lo hi)
+		  (make-numeric-type
+		   :class 'float
+		   :format (or (numeric-type-format arg) 'single-float)
+		   :low (or (bound-func fcn lo) default-lo)
+		   :high (or (bound-func fcn hi) default-hi))
+		  (float-or-complex-type arg))))
+	   (t
+	    (float-or-complex-type arg default-lo default-hi))))))
+
+(macrolet
+    ((frob (name cond def-lo-bnd def-hi-bnd)
+       (let ((num (gensym)))
+	 `(progn
+	   (defoptimizer (,name derive-type) ((,num))
+	     (one-arg-derive-type
+	      ,num
+	      #'(lambda (arg)
+		  (elfun-derive-type-simple arg #',name
+					    ,cond
+					    ,def-lo-bnd ,def-hi-bnd))))))))
   ;; These functions are easy because they are defined for the whole
   ;; real line.
   (frob exp (constantly t)
@@ -684,8 +645,7 @@
   ;; return value of (OR FLOAT (COMPLEX FLOAT)) is ok as the default.
   (frob sqrt #'(lambda (lo hi)
 		 (declare (ignore hi))
-		 (and lo
-		      (>= (bound-value lo) 0)))
+		 (and lo (> (bound-value lo) 0)))
 	0 nil)
   (frob asin #'(lambda (lo hi)
 		 (and lo hi
@@ -702,25 +662,44 @@
 		       (<= (bound-value hi) 1)))
 	-1 1))
 
-
-;;; acos is monotonic decreasing, so we need to swap the function
+;;; Acos is monotonic decreasing, so we need to swap the function
 ;;; values at the lower and upper bounds of the input domain.
+;;;
+(defun acos-derive-type-aux (arg)
+  (etypecase arg
+    (numeric-type
+     (cond ((eq (numeric-type-complexp arg) :complex)
+	    (make-numeric-type :class (numeric-type-class arg)
+			       :format (numeric-type-format arg)
+			       :complexp :complex
+			       :low nil
+			       :high nil))
+	   ((numeric-type-real-p arg)
+	    (let ((float-type (or (numeric-type-format arg) 'float))
+		  (lo (numeric-type-low arg))
+		  (hi (numeric-type-high arg)))
+	      (cond
+		((and lo hi
+		      (>= (bound-value lo) -1)
+		      (<= (bound-value hi) 1))
+		 (setf lo (or (bound-func #'acos (numeric-type-high arg)) 0))
+		 (setf hi (or (bound-func #'acos (numeric-type-low arg)) pi))
+		 (specifier-type `(,float-type
+				   ,(and lo (coerce lo float-type))
+				   ,(and hi (coerce hi float-type)))))
+		(t
+		 (float-or-complex-type arg 0 pi)))))
+	   (t
+	    (float-or-complex-type arg 0 pi))))))
+;;;
 (defoptimizer (acos derive-type) ((num))
-  (elfun-derive-type-union
-   (continuation-type num)
-   #'(lambda (lo hi)
-       (and lo hi
-	    (>= (bound-value lo) -1)
-	    (<= (bound-value hi) 1)))
-   #'(lambda (lo hi)
-       (values (bound-func #'acos hi)
-	       (bound-func #'acos lo)))))
+  (one-arg-derive-type num #'acos-derive-type-aux))
 
 
 ;;; Compute bounds for (expt x y).  This should be easy since (expt x
 ;;; y) = (exp (* y (log x))).  However, computations done this way
 ;;; have too much roundoff.  Thus we have to do it the hard way.
-  
+;;;  
 (defun safe-expt (x y)
   (handler-case
       (expt x y)
@@ -806,10 +785,10 @@
      ;; X <= 1
      (interval-expt-< x y))
     (t
-	 (destructuring-bind (left right)
+     (destructuring-bind (left right)
 	 (interval-split 1 x t t)
-	   (list (interval-expt left y)
-		 (interval-expt right y))))))
+       (list (interval-expt left y)
+	     (interval-expt right y))))))
 
 (defun fixup-interval-expt (bnd x-int y-int x-type y-type)
   (declare (ignore x-int))
@@ -859,37 +838,36 @@
 		   (t (flatten-helper (car x)
 				      (flatten-helper (cdr x) r)))))
 	   (flatten (x) (flatten-helper x nil)))
-  (let* ((x-int (numeric-type->interval x-type))
-	 (y-int (numeric-type->interval y-type))
-	 (bnd (interval-expt x-int y-int))
-	 (union '()))
-    (dolist (type (flatten bnd))
-      (push (fixup-interval-expt type x-int y-int x-type y-type)
-	    union))
-    (let ((merged (derive-merged-union-types union)))
-      (assert (null (rest merged)))	; There should be only one thing left!
-      (first merged)))))
+    (let* ((x-int (numeric-type->interval x-type))
+	   (y-int (numeric-type->interval y-type))
+	   (bnd (interval-expt x-int y-int))
+	   (union '()))
+      (dolist (type (flatten bnd))
+	(push (fixup-interval-expt type x-int y-int x-type y-type) union))
+      (let ((merged (derive-merged-union-types union)))
+	(assert (null (rest merged)))	; There should be only one thing left!
+	(first merged)))))
 
 ;; Derive the type of (expt x-type y-type)
 (defun expt-derive-type-aux-numeric (x-type y-type)
-    (if (or (eq (numeric-type-complexp x-type) :complex)
-	    (eq (numeric-type-complexp y-type) :complex))
-	(numeric-contagion x-type y-type)
-	(if (eq (numeric-type-class y-type) 'integer)
-	    ;; A real raised to an integer power is well-defined
-	    (merged-interval-expt x-type y-type)
-	    ;; A real raised to a non-integral power can be a float or
-	    ;; a complex number.
-	    (cond ((and (bound-value (numeric-type-low x-type))
-			(>= (bound-value (numeric-type-low x-type)) 0))
-		   ;; A non-negative real to some power is fairly easy
-		   ;; to handle.
-		   (merged-interval-expt x-type y-type))
-		  (t
-		   ;; A number to some power.  We punt here.
-		   (format t "x-type, y-type = ~a ~a~%" x-type y-type)
-		   (error "Can't happen!")
-		   (specifier-type '(or float (complex float))))))))
+  (if (or (eq (numeric-type-complexp x-type) :complex)
+	  (eq (numeric-type-complexp y-type) :complex))
+      (numeric-contagion x-type y-type)
+      (if (eq (numeric-type-class y-type) 'integer)
+	  ;; A real raised to an integer power is well-defined
+	  (merged-interval-expt x-type y-type)
+	  ;; A real raised to a non-integral power can be a float or
+	  ;; a complex number.
+	  (cond ((and (bound-value (numeric-type-low x-type))
+		      (>= (bound-value (numeric-type-low x-type)) 0))
+		 ;; A non-negative real to some power is fairly easy
+		 ;; to handle.
+		 (merged-interval-expt x-type y-type))
+		(t
+		 ;; A number to some power.  We punt here.
+		 (format t "x-type, y-type = ~a ~a~%" x-type y-type)
+		 (error "Can't happen!")
+		 (specifier-type '(or float (complex float))))))))
 
 (defun expt-derive-type-aux (x-type y-type)
   (let ((result (expt-derive-type-aux-numeric x-type y-type)))
@@ -899,124 +877,73 @@
 	    (numeric-type-format result))))
 
 
-(defoptimizer (expt derive-type) ((x y))
-  (let ((x-type (continuation-type x))
-	(y-type (continuation-type y)))
-    (if (or (eq (numeric-type-complexp x-type) :complex)
-	    (eq (numeric-type-complexp y-type) :complex))
-	(numeric-contagion x-type y-type)
-	(if (eq (numeric-type-class y-type) 'integer)
-	    ;; A real raised to an integer power is well-defined
-	    (merged-interval-expt x-type y-type)
-	    ;; A real raised to a non-integral power can be a float or
-	    ;; a complex number.
-	    (cond ((and (bound-value (numeric-type-low x-type))
-			(>= (bound-value (numeric-type-low x-type)) 0))
-		   ;; A non-negative real to some power is fairly easy
-		   ;; to handle.
-		   (derive-real-numeric-or-union-type
-		    x-type y-type #'expt-derive-type-aux))
-
-			      (t
-		   ;; A number to some power.  We punt here.
-		   (float-or-complex-type
-		    (numeric-contagion x-type y-type))))))))
-
+;;; Note must assume that a type including 0.0 may also include -0.0
+;;; and thus the result may be -infinity + i*pi.
+;;;
+(defun log-derive-type-aux-1 (arg)
+  (elfun-derive-type-simple
+   arg #'log #'(lambda (lo hi)
+		 (declare (ignore hi))
+		 (and lo (> (bound-value lo) 0)))
+   nil nil))
+
+(defun log-derive-type-aux (x y same-arg)
+  (let ((log-x (log-derive-type-aux-1 x))
+	(log-y (log-derive-type-aux-1 y))
+	(result '()))
+    ;; log-x or log-y might be union types.  We need to run through
+    ;; the union types ourselves because /-derive-type-aux doesn't.
+    (dolist (x-type (prepare-arg-for-derive-type log-x))
+      (dolist (y-type (prepare-arg-for-derive-type log-y))
+	(push (/-derive-type-aux x-type y-type same-arg) result)))
+    (setf result (flatten-list result))
+    (if (rest result)
+	(make-union-type result)
+	(first result))))
 
 (defoptimizer (log derive-type) ((x &optional y))
-  (flet ((derive-type (arg)
-	   (elfun-derive-type-union
-	    (continuation-type arg)
-	    #'(lambda (lo hi)
-		(declare (ignore hi))
-		(and lo
-		     (>= (bound-value lo) 0)))
-	    #'(lambda (lo hi)
-		(values
-		 (if (zerop (bound-value lo))
-		     nil
-		     (set-bound (log (bound-value lo)) (consp lo)))
-		 (if hi
-		     (set-bound (log (bound-value hi)) (consp hi))
-		     nil))))))
-    (cond ((null y)
-	   ;; The easy one arg case
-	   (derive-type x))
-	  (t
-	   ;; The hard case with a base given.  Use the definition of
-	   ;; (log x y) = (/ (log x) (log y)) to figure out what the
-	   ;; answer should be.
-	   (let ((log-x (derive-type x))
-		 (log-y (derive-type y)))
-	     (cond ((and (numeric-type-real-p log-x)
-			 (numeric-type-real-p log-y))
-		    ;; This stolen from the optimizer for /. 
-		    (derive-real-numeric-or-union-type
-		     log-x log-y
-		     #'(lambda (x y)
-			 (declare (type numeric-type x y))
-			 (let ((result
-				(interval-div (numeric-type->interval x)
-						     (numeric-type->interval y)))
-			       (result-type (numeric-contagion x y)))
-			   ;; If the result type is a float, we need
-			   ;; to be sure to coerce the bounds into the
-			   ;; correct type.
-			   (when (eq (numeric-type-class result-type) 'float)
-			     (setf result (interval-func
-					   #'(lambda (x)
-					       (coerce x (or (numeric-type-format result-type)
-							     'float)))
-					   result)))
-			   (values (interval-low result)
-				   (interval-high result)
-				   (numeric-type-class result-type)
-				   (numeric-type-format result-type))))))
-		   (t
-		    ;; The result can be a float or a complex.  Get
-		    ;; the right type of float, if possible.
-		    (float-or-complex-type
-		     (numeric-contagion
-		      (continuation-type x)
-		      (continuation-type y))))))))))
+  (if y
+      (two-arg-derive-type x y #'log-derive-type-aux)
+      (one-arg-derive-type x #'log-derive-type-aux-1)))
+
+
+(defun atan-derive-type-aux-1 (y)
+  (elfun-derive-type-simple
+   y #'atan (constantly t) #.(- (/ pi 2)) #.(/ pi 2)))
+
+(defun atan-derive-type-aux-2 (y x same-arg)
+  (declare (ignore same-arg))
+  ;; The hard case with two args.  We just return the max bounds.
+  (cond ((and (numeric-type-real-p x)
+	      (numeric-type-real-p y))
+	 (make-numeric-type
+	  :class 'float
+	  :format (float-format-max
+		   (numeric-type-format y)
+		   (numeric-type-format x))
+	  :complexp :real
+	  :low #.(- pi)
+	  :high #.pi))
+	(t
+	 ;; The result is a float or a complex number
+	 (float-or-complex-type (numeric-contagion x y)))))
 
 (defoptimizer (atan derive-type) ((y &optional x))
   (cond ((null x)
-	 ;; Let's handle the easy one arg case
-	 (elfun-derive-type-union
-	  (continuation-type y)
-	  #'(lambda (lo hi)
-	      (declare (ignore lo hi))
-	      t)
-	  #'(lambda (lo hi)
-	      (values (or (bound-func #'atan lo) #.(- (/ pi 2)))
-		      (or (bound-func #'atan hi) #.(/ pi 2))))))
+	 (one-arg-derive-type y #'atan-derive-type-aux-1))
 	(t
-	 ;; Here is the hard case with two args.  However, we punt on
-	 ;; it, and just return the max bounds.
-	 (when (numeric-type-real-p (continuation-type x))
-	   (make-numeric-type
-	    :class 'float
-	    :format (float-format-max
-		     (numeric-type-format (continuation-type y))
-		     (numeric-type-format (continuation-type x)))
-	    :complexp :real
-	    :low #.(- pi)
-	    :high #.pi)))))
-      
+	 (two-arg-derive-type y x #'atan-derive-type-aux-2))))
+
+
+(defun cosh-derive-type-aux (x)
+  (elfun-derive-type-simple
+   (if (numeric-type-real-p x)
+       (abs-derive-type-aux x)
+       x)
+   #'cosh (constantly t) 0 nil))
 
 (defoptimizer (cosh derive-type) ((num))
-  (elfun-derive-type-union
-   (continuation-type num)
-   #'(lambda (lo hi)
-       (declare (ignore lo hi))
-       t)
-   #'(lambda (lo hi)
-       ;; Note that cosh(x) = cosh(|x|), and that cosh is monotonic
-       ;; increasing for the positive line.
-       (let ((x (interval-abs (make-interval :low lo :high hi))))
-	 (values (bound-func #'cosh (interval-low x))
-		 (bound-func #'cosh (interval-high x)))))))
+  (one-arg-derive-type num #'cosh-derive-type-aux))
 
 
 (defun phase-derive-type-aux (type)
@@ -1067,42 +994,7 @@
 			    :high pi))))
 
 (defoptimizer (phase derive-type) ((num))
-  (let ((type (continuation-type num)))
-    (cond ((numeric-type-real-p type)
-	   (let ((res (phase-derive-type-aux type)))
-	     (if (listp res)
-		 (make-union-type res)
-		 res)))
-	  ((union-type-p type)
-	   ;; Run down the list and process each type
-	   (let ((result '()))
-	     (dolist (interval (union-type-types type))
-	       (let ((res-1 (phase-derive-type-aux interval)))
-		 (cond ((listp res-1)
-			(push (first res-1) result)
-			(push (second res-1) result))
-		       (t
-			(push res-1 result)))))
-	     (make-union-type (derive-merged-union-types result)))))))
-		 
-
-;;; Conjugate always returns the same type as the input type.
-;;;
-(defoptimizer (conjugate derive-type) ((num))
-  (continuation-type num))
-
-(defoptimizer (cis derive-type) ((num))
-  (let ((num-type (continuation-type num)))
-    (flet ((cis-type (x)
-	     ;; Cis of a double-float is (complex double-float).
-	     ;; Otherwise it's (complex single-float).
-	     (if (eq (numeric-type-format x) 'double-float)
-		 (c::specifier-type '(complex double-float))
-		 (c::specifier-type '(complex single-float)))))
-    (if (union-type-p num-type)
-	(make-union-type (mapcar #'cis-type
-				 (union-type-types num-type)))
-	(cis-type num-type)))))
+  (one-arg-derive-type num #'phase-derive-type-aux))
 
 ) ;end progn for propagate-fun-type
 
@@ -1117,133 +1009,120 @@
 
 ;;; Make REALPART and IMAGPART return the appropriate types.  This
 ;;; should help a lot in optimized code.
-(defoptimizer (realpart derive-type) ((num))
-  (flet ((realpart-derive (type)
+
+(defun realpart-derive-type-aux (type)
     (cond ((numeric-type-real-p type)
-		  ;; The realpart of a real has the same type and
-		  ;; range as the input.
+	   ;; The realpart of a real has the same type and range as
+	   ;; the input.
 	   (make-numeric-type :class (numeric-type-class type)
 			      :format (numeric-type-format type)
 			      :complexp :real
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type)))
-	  (t
-		  ;; We have a complex number.  The result has the
-		  ;; same type as the real part, except that it's
-		  ;; real, not complex, obviously.
-	   (make-numeric-type :class (numeric-type-class type)
-			      :format (numeric-type-format type)
-			      :complexp :real
-			      :low (numeric-type-low type)
-			      :high (numeric-type-high type))))))
-    (let ((type (continuation-type num)))
-      (cond ((union-type-p type)
-	     (let ((result '()))
-	       (dolist (x (union-type-types type))
-		 (push (realpart-derive x) result))
-	       (make-union-type result)))
-	    (t
-	     (realpart-derive type))))))
-
-(defoptimizer (imagpart derive-type) ((num))
-  (flet ((imagpart-derive (type)
-    (cond ((numeric-type-real-p type)
-	   ;; The imagpart of a real has the same type as the input,
-	   ;; except that it's zero
-	   (make-numeric-type :class (numeric-type-class type)
-			      :format (numeric-type-format type)
-			      :complexp :real
-			      :low 0
-			      :high 0))
 	  (t
 	   ;; We have a complex number.  The result has the same type
-	   ;; as the imaginary part, except that it's real, not complex,
+	   ;; as the real part, except that it's real, not complex,
 	   ;; obviously.
 	   (make-numeric-type :class (numeric-type-class type)
 			      :format (numeric-type-format type)
 			      :complexp :real
 			      :low (numeric-type-low type)
-			      :high (numeric-type-high type))))))
-    (let ((type (continuation-type num)))
-      (cond ((union-type-p type)
-	     (let ((result '()))
-	       (dolist (x (union-type-types type))
-		 (push (imagpart-derive x) result))
-	       (make-union-type result)))
-	    (t
-	     (imagpart-derive type))))))
+			      :high (numeric-type-high type)))))
+
+(defoptimizer (realpart derive-type) ((num))
+  (one-arg-derive-type num #'realpart-derive-type-aux))
+
+(defun imagpart-derive-type-aux (type)
+  (cond ((numeric-type-real-p type)
+	 ;; The imagpart of a real has the same type as the input,
+	 ;; except that it's zero
+	 (make-numeric-type :class (numeric-type-class type)
+			    :format (numeric-type-format type)
+			    :complexp :real
+			    :low 0
+			    :high 0))
+	(t
+	 ;; We have a complex number.  The result has the same type as
+	 ;; the imaginary part, except that it's real, not complex,
+	 ;; obviously.
+	 (make-numeric-type :class (numeric-type-class type)
+			    :format (numeric-type-format type)
+			    :complexp :real
+			    :low (numeric-type-low type)
+			    :high (numeric-type-high type)))))
+
+(defoptimizer (imagpart derive-type) ((num))
+  (one-arg-derive-type num #'imagpart-derive-type-aux))
+
+(defun complex-derive-type-aux-1 (re-type)
+  (if (numeric-type-p re-type)
+      (make-numeric-type :class (numeric-type-class re-type)
+			 :format (numeric-type-format re-type)
+			 :complexp (if (csubtypep re-type
+						  (specifier-type 'rational))
+				       :real
+				       :complex)
+			 :low (numeric-type-low re-type)
+			 :high (numeric-type-high re-type))
+      (specifier-type 'complex)))
+
+(defun complex-derive-type-aux-2 (re-type im-type same-arg)
+  (declare (ignore same-arg)
+	   (optimize (debug 3) (safety 3)))
+  (if (and (numeric-type-p re-type)
+	   (numeric-type-p im-type))
+      ;; Need to check to make sure numeric-contagion returns the
+      ;; right type for what we want here.
+      
+      ;; Also, what about rational canonicalization, like (complex 5 0)
+      ;; is 5?  So, if the result must be complex, we make it so.
+      ;; If the result might be complex, which happens only if the
+      ;; arguments are rational, we make it a union type of (or
+      ;; rational (complex rational)).
+      (let* ((element-type (numeric-contagion re-type im-type))
+	     (rat-result-p (csubtypep element-type
+				      (specifier-type 'rational))))
+	(if rat-result-p
+	    (make-union-type
+	     (list element-type
+		   (specifier-type 
+		    `(complex ,(numeric-type-class element-type)))))
+	    (make-numeric-type :class (numeric-type-class element-type)
+			       :format (numeric-type-format element-type)
+			       :complexp (if rat-result-p
+					     :real
+					     :complex))))
+      (specifier-type 'complex)))
 
 (defoptimizer (complex derive-type) ((re &optional im))
   (if im
-      (let ((re-type (continuation-type re))
-	    (im-type (continuation-type im)))
-	(if (and (numeric-type-p re-type)
-		 (numeric-type-p im-type))
-	    ;; Need to check to make sure numeric-contagion returns
-	    ;; the right type for what we want here.
-
-	    ;; Also, what about rational canonicalization, like
-	    ;; (complex 5 0) is 5?  So, if the result must be complex,
-	    ;; we make it so.  If the result might be complex, which
-	    ;; happens only if the arguments are rational, we make it
-	    ;; a union type of (or rational (complex rational)).
-	    (let* ((element-type (numeric-contagion re-type im-type))
-		   (rat-result-p (csubtypep element-type
-					    (specifier-type 'rational))))
-	      (if rat-result-p
-		  (make-union-type
-		   (list element-type
-			 (specifier-type `(complex ,(numeric-type-class element-type)))))
-		  (make-numeric-type :class (numeric-type-class element-type)
-				     :format (numeric-type-format element-type)
-				     :complexp (if rat-result-p
-						   :real
-						   :complex))))
-	    (specifier-type 'complex)))
-      (let ((re-type (continuation-type re)))
-	(if (numeric-type-p re-type)
-	    (make-numeric-type :class (numeric-type-class re-type)
-			       :format (numeric-type-format re-type)
-			       :complexp (if (csubtypep re-type
-							(specifier-type 'rational))
-					     :real
-					     :complex)
-			       :low (numeric-type-low re-type)
-			       :high (numeric-type-high re-type))
-	    (specifier-type 'complex)))))
-
-(macrolet ((frob (op type)
-	     `(deftransform ,op ((w z) ((complex ,type) (complex ,type)) *)
-	        '(complex (,op (realpart w) (realpart z))
-			  (,op (imagpart w) (imagpart z))))))
-  ;; Complex addition and subtraction
-  (frob + single-float)
-  (frob + double-float)
-  (frob - single-float)
-  (frob - double-float))
+      (two-arg-derive-type re im #'complex-derive-type-aux-2)
+      (one-arg-derive-type re #'complex-derive-type-aux-1)))
 
+
+;;; Define some transforms for complex operations.  We do this in lieu
+;;; of complex operation VOPs.
+;;;
 (macrolet ((frob (type)
 	     `(progn
+	       ;; Complex addition and subtraction
+	       (deftransform + ((w z) ((complex ,type) (complex ,type)) *)
+		 '(complex (+ (realpart w) (realpart z))
+			   (+ (imagpart w) (imagpart z))))
+	       (deftransform - ((w z) ((complex ,type) (complex ,type)) *)
+		 '(complex (- (realpart w) (realpart z))
+			   (- (imagpart w) (imagpart z))))
+	       ;; Add and subtract a complex and a float
 	       (deftransform + ((w z) ((complex ,type) ,type) *)
 		 '(complex (+ (realpart w) z) (imagpart w)))
 	       (deftransform + ((z w) (,type (complex ,type)) *)
-		 '(complex (+ (realpart w) z) (imagpart w))))))
-  ;; Add and sub between a complex number and a float.
-  (frob single-float)
-  (frob double-float))
-
-(macrolet ((frob (type)
-	     `(progn
+		 '(complex (+ (realpart w) z) (imagpart w)))
+	       ;; Add and subtract a float and a complex number
 	       (deftransform - ((w z) ((complex ,type) ,type) *)
 		 '(complex (- (realpart w) z) (imagpart w)))
 	       (deftransform - ((z w) (,type (complex ,type)) *)
-		 '(complex (- z (realpart w)) (- (imagpart w)))))))
-  ;; Add and sub between a complex number and a float.
-  (frob single-float)
-  (frob double-float))
-
-(macrolet ((frob (type)
-	     `(progn
+		 '(complex (- z (realpart w)) (- (imagpart w))))
+	       ;; Multiply and divide two complex numbers
 	       (deftransform * ((x y) ((complex ,type) (complex ,type)) *)
 		 '(let* ((rx (realpart x))
 			 (ix (imagpart x))
@@ -1264,73 +1143,84 @@
 			(let* ((r (/ ry iy))
 			       (dn (* iy (+ 1 (* r r)))))
 			  (complex (/ (+ (* rx r) ix) dn)
-				   (/ (- (* ix r) rx) dn)))))))))
-  ;; Multiplication and division for complex numbers
-  (frob single-float)
-  (frob double-float))
-
-(macrolet ((frob (type)
-	     `(progn
+				   (/ (- (* ix r) rx) dn))))))
+	       ;; Multiplye a complex by a float or vice versa
 	       (deftransform * ((w z) ((complex ,type) ,type) *)
 		 '(complex (* (realpart w) z) (* (imagpart w) z)))
 	       (deftransform * ((z w) (,type (complex ,type)) *)
-		 '(complex (* (realpart w) z) (* (imagpart w) z))))))
-  (frob single-float)
-  (frob double-float))
+		 '(complex (* (realpart w) z) (* (imagpart w) z)))
+	       ;; Divide a complex by a float
+	       (deftransform / ((w z) ((complex ,type) ,type) *)
+		 '(complex (/ (realpart w) z) (/ (imagpart w) z)))
+	       ;; Conjugate of a float or complex number
+	       (deftransform conjugate ((z) ((complex ,type)) *)
+		 '(complex (realpart z) (- (imagpart z))))
+	       ;; Cis.
+	       (deftransform cis ((z) ((,type)) *)
+		 '(complex (cos z) (sin z))))))
 
-(macrolet ((frob (type)
-	     `(deftransform / ((w z) ((complex ,type) ,type) *)
-	       '(complex (/ (realpart w) z) (/ (imagpart w) z)))))
-  (frob single-float)
-  (frob double-float))
-	   
-(macrolet ((frob (type)
-	     `(deftransform conjugate ((z) ((complex ,type)) *)
-	       '(complex (realpart z) (- (imagpart z))))))
   (frob single-float)
   (frob double-float))
 
-(macrolet ((frob (type)
-	     `(deftransform cis ((z) ((,type)) *)
-	       '(complex (cos z) (sin z)))))
-  (frob single-float)
-  (frob double-float))
 
 ;;; Here are simple optimizers for sin, cos, and tan.  They do not
 ;;; produce a minimal range for the result; the result is the widest
 ;;; possible answer.  This gets around the problem of doing range
 ;;; reduction correctly but still provides useful results when the
 ;;; inputs are union types.
-;;;
-;;; However, there appears to be a harmless bug somewhere.  The result
-;;; type of (sin z) where z is complex is (complex (float -1.0 1.0)).
-;;; This is wrong, but it seems the compiler doesn't produce a
-;;; type-check to see if the elements of the complex are really (float
-;;; -1.0 1.0).
 
 #+propagate-fun-type
 (progn
+(defun sincos-derive-type-aux (arg)
+  (etypecase arg
+    (numeric-type
+     (cond ((eq (numeric-type-complexp arg) :complex)
+	    (make-numeric-type :class (numeric-type-class arg)
+			       :format (numeric-type-format arg)
+			       :complexp :complex
+			       :low nil
+			       :high nil))
+	   ((numeric-type-real-p arg)
+	    (let ((float-type (or (numeric-type-format arg) 'float)))
+	      (specifier-type `(,float-type
+				,(coerce -1 float-type)
+				,(coerce 1 float-type)))))
+	   (t
+	    (float-or-complex-type arg -1 1))))))
+
 (defoptimizer (sin derive-type) ((num))
-  (elfun-derive-type-union
-   (continuation-type num)
-   (constantly t)
-   #'(lambda (lo hi)
-       (declare (ignore lo hi))
-       (values -1d0 1d0))))
+  (one-arg-derive-type num #'sincos-derive-type-aux))
        
 (defoptimizer (cos derive-type) ((num))
-  (elfun-derive-type-union
-   (continuation-type num)
-   (constantly t)
-   #'(lambda (lo hi)
-       (declare (ignore lo hi))
-       (values -1d0 1d0))))
+  (one-arg-derive-type num #'sincos-derive-type-aux))
+
+
+(defun tan-derive-type-aux (arg)
+  (etypecase arg
+    (numeric-type
+     (cond ((eq (numeric-type-complexp arg) :complex)
+	    (make-numeric-type :class (numeric-type-class arg)
+			       :format (numeric-type-format arg)
+			       :complexp :complex
+			       :low nil
+			       :high nil))
+	   ((numeric-type-real-p arg)
+	    (let ((float-type (or (numeric-type-format arg) 'float)))
+	      (specifier-type float-type)))
+	   (t
+	    (float-or-complex-type arg))))))
 
 (defoptimizer (tan derive-type) ((num))
-  (elfun-derive-type-union
-   (continuation-type num)
-   (constantly t)
-   #'(lambda (lo hi)
-       (declare (ignore lo hi))
-       (values nil nil))))
-)					; end progn
+  (one-arg-derive-type num #'tan-derive-type-aux))
+
+;;; conjugate always returns the same type as the input type  
+(defoptimizer (conjugate derive-type) ((num))
+  (continuation-type num))
+
+(defoptimizer (cis derive-type) ((num))
+  (one-arg-derive-type num
+     #'(lambda (arg)
+	 (c::specifier-type
+	  `(complex ,(or (numeric-type-format arg) 'single-float))))))
+
+) ; end progn
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 1301148d6..93470a953 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.63 1997/12/11 22:28:50 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.64 1997/12/14 14:10:24 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -298,7 +298,7 @@
     (%make-interval :low (normalize-bound low)
 		    :high (normalize-bound high))))
 
-(proclaim '(inline bound-value set-bound bound-func))
+(proclaim '(inline bound-value set-bound))
 
 ;;; Extract the numeric value of a bound.  Return NIL, if X is NIL.
 (defun bound-value (x)
@@ -314,7 +314,14 @@
 (defun bound-func (f x)
   (and x
        (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
-	 (set-bound (funcall f (bound-value x)) (consp x)))))
+	 ;; With these traps masked, we might get things like infinity
+	 ;; or negative infinity returned.  Check for this and return
+	 ;; NIL to indicate unbounded.
+	 (let ((y (funcall f (bound-value x))))
+	   (if (and (floatp y)
+		    (float-infinity-p y))
+	       nil
+	       (set-bound (funcall f (bound-value x)) (consp x)))))))
 
 ;;; Apply a binary operator OP to two bounds X and Y.  The result is
 ;;; NIL if either is NIL.  Otherwise bound is computed and the result
@@ -776,166 +783,112 @@
 			     :low low  :high high))
 	(numeric-contagion x y))))
 
-;;; Derive-Real-Type  --  Internal
-;;;
-;;; Same as derive-integer-type except it can handle float types.
-;;; This also contains derive-integer-type as a special case.
-;;;
-#+propagate-float-type
+#+(or propagate-float-type propagate-fun-type)
 (progn
-;;; Some functions only take one argument but derive-real-type assumes
-;;; two.  For those cases of one argument functions, set IGNORE-Y to T
-;;; because we don't want derive-real-type to process the second
-;;; argument because it's meaningless.
 
-(defun derive-real-type (x y fun)
-  (declare (type continuation x y) (type function fun))
-  (let ((x (continuation-type x))
-	(y (continuation-type y)))
-    (derive-real-numeric-or-union-type x y fun)))
-
-;;; Some notes: This routine can handle X and Y if they are
-;;; numeric-types or unions of numeric types.  If this is not true,
-;;; general numeric contagion holds.  In particular if X is a member
-;;; type, we could conceivably compute the right thing by looking
-;;; inside the elements of the member type.  We don't do this yet.
-;;; Perhaps it would be better to let the user say so.  Instead of
-;;; saying (member 1 2 4), you should say (or (integer 1 1) (integer 2
-;;; 2) (integer 4 4)).
-;;;
-(defun derive-real-numeric-or-union-type (x y fun)
-  (labels ((combine (lx ly)
-	     ;; Creates a new list containing all possible pairs from
-	     ;; LX and LY.
-	     (let ((result '()))
-	       (dolist (ix lx)
-		 (dolist (iy ly)
-		   (push (list ix iy) result)))
-	       (nreverse result)))
-	   (listify (object)
-	     ;; If object is a union type, get the list of the types.
-	     ;; Otherwise make a list containing the single object.
-	     (typecase object
-	       (union-type
-		(union-type-types object))
-	       (t
-		(list object)))))
-	(let ((all (combine (listify x)
-			    (listify y)))
-	      (result '()))
-	  (dolist (item all)
-	    (destructuring-bind (ix iy)
-		item
-	      (push (derive-simple-real-type ix iy fun) result)))
-	  (setf result (derive-merged-union-types result))
-	  (if (cdr result)
+;; Simple utility to flatten a list
+(defun flatten-list (x)
+  (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
+	     (cond ((null x) r)
+		   ((atom x)
+		    (cons x r))
+		   (t (flatten-helper (car x)
+				      (flatten-helper (cdr x) r))))))
+    (flatten-helper x nil)))
+
+(defun prepare-arg-for-derive-type (arg)
+  ;; Take some type of continuation and massage it so that we get a
+  ;; list of the constituent types.  If ARG is *EMPTY-TYPE*, return
+  ;; NIL to indicate failure.
+  ;;
+  ;; WARNING: For some reason if ARG is of type (member 1 a), this
+  ;; routine only gets (member 1).  I don't know why.
+  (flet ((listify (arg)
+	   (typecase arg
+	     (numeric-type
+	      (list arg))
+	     (union-type
+	      (union-type-types arg))
+	     (t
+	      (list arg))))
+	 (convert-member-type (type)
+	   ;; Run down the list of members and convert to the
+	   ;; appropriate numeric-type.
+	   (mapcar #'(lambda (element)
+		       (if (numberp element)
+			   (let ((type (type-of element)))
+			     (specifier-type `(,(if (subtypep type 'integer)
+						    'integer
+						    type) ,element ,element)))
+			   *empty-type*))
+		   (member-type-members type))))
+    (when (eq arg *empty-type*)
+      (return-from prepare-arg-for-derive-type nil))
+    ;; Make sure all args are some type of numeric-type.  For member
+    ;; types, convert the list of members into a union of equivalent
+    ;; numeric-types.
+    (let ((new-args (flatten-list (mapcar #'(lambda (x)
+					      (if (member-type-p x)
+						  (convert-member-type x)
+						  x))
+					  (listify arg)))))
+      (if (member *empty-type* new-args)
+	  nil
+	  new-args))))
+
+
+;;; ONE-ARG-DERIVE-TYPE
+;;;
+;;; This is used in defoptimizers for computing the resulting type of
+;;; a function.
+;;;
+;;; Given the continuation ARG, derive the resulting type using the
+;;; DERIVE-FCN.  DERIVE-FCN takes exactly one argument which is some
+;;; "atomic" continuation type like numeric-type.  It should return
+;;; the resulting type, which can be a list of types.
+;;;
+(defun one-arg-derive-type (arg derive-fcn)
+  (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg)))
+	(result '()))
+    (when arg-list
+      ;; Run down the list of args and derive the type of each one and
+      ;; save all of the results in a list.
+      (setf result (flatten-list (mapcar derive-fcn arg-list)))
+      (if (rest result)
+	  (make-union-type result)
+	  (first result)))))
+
+;;; TWO-ARG-DERIVE-TYPE
+;;;
+;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
+;;; two arguments.  DERIVE-FCN takes 3 args in this case: the two
+;;; original args and a third which is T to indicate if the two args
+;;; really represent the same continuation.  This is useful for
+;;; deriving the type of things like (* x x), which should always be
+;;; positive.  If we didn't do this, we wouldn't be able to tell.
+;;;
+(defun two-arg-derive-type (arg1 arg2 derive-fcn)
+  (let ((same-arg (same-leaf-ref-p arg1 arg2))
+	(a1 (prepare-arg-for-derive-type (continuation-type arg1)))
+	(a2 (prepare-arg-for-derive-type (continuation-type arg2)))
+	(result '()))
+    (when (and a1 a2)
+      (if same-arg
+	  ;; Since the args are the same continuation, just run down on
+	  ;; of the lists.
+	  (dolist (x a1)
+	    (push (funcall derive-fcn x x same-arg) result))
+	  ;; Try all pairwise combinations and gather the result
+	  (dolist (x a1)
+	    (dolist (y a2)
+	      (push (or (funcall derive-fcn x y same-arg)
+			(numeric-contagion x y))
+		    result))))
+      (setf result (flatten-list result))
+      (if (rest result)
 	      (make-union-type result)
 	      (first result)))))
 
-;;; Merge the first interval in the list with the rest of intervals in
-;;; the list.  The list of intervals MUST be sorted in ascending order
-;;; of lower limits.
-;;;  
-(defun merge-types-aux (tlist)
-  (let* ((cur (first tlist))
-	 (cur-interval (if (numeric-type-real-p cur)
-			   (numeric-type->interval cur)
-			   nil))
-	 (res '()))
-    (dolist (this-interval (rest tlist) (cons cur res))
-      (let ((this (if (numeric-type-real-p this-interval)
-		      (numeric-type->interval this-interval)
-		      nil)))
-	;; If the current interval is complex (cur-interval is nil) or
-	;; the next interval is complex (this is nil), we just simply
-	;; add that to the resulting list.  That is we don't try to
-	;; merge complex types at all.
-	;;
-	;; If interval intersects cur or if they are adjacent, we can
-	;; merge them together, but only if they are the same type of
-	;; number.  If they are different, we can't merge them.
-	(cond ((and cur-interval this
-		    (eq (numeric-type-class cur) 
-			(numeric-type-class this-interval))
-		    (eq (numeric-type-format cur)
-			(numeric-type-format this-interval))
-		    (or (interval-intersect-p cur-interval this)
-			(interval-adjacent-p cur-interval this)))
-	       (let ((result (interval-merge-pair cur-interval this)))
-		 (when result
-		   (setf cur-interval result)
-		   (setf (numeric-type-low cur) (interval-low result))
-		   (setf (numeric-type-high cur) (interval-high result)))))
-	      (t
-	       (push this-interval res)))))))
-
-;;; Compare the first element with the rest to merge whatever we can
-;;; into the first element.  The first element is totally merged, so
-;;; we only need to consider whatever is left.
-;;;
-(defun merge-types (ilist &optional (result '()))
-  (cond ((null ilist)
-	 result)
-	((cdr ilist)
-	 (let ((new-types (merge-types-aux ilist)))
-	   (merge-types (rest new-types) (cons (first new-types) result))))
-	(t
-	 (cons (first ilist) result))))
-
-(defun derive-merged-union-types (types)
-  (labels ((num-interval-< (a b)
-	     (when (and (numeric-type-p a)
-			(numeric-type-p b))
-	       (let ((a-lo (numeric-type-low a))
-		     (b-lo (numeric-type-low b)))
-		 (cond ((null a-lo)
-			;; A has lower bound of -infinity, so it's
-			;; lower than B, no matter what B is.
-			t)
-		       ((null b-lo)
-			;; At this point A has a numeric lower bound,
-			;; but B has -infinity, so A is not lower than
-			;; B.
-			nil)
-		       (t
-			;; Both A and B have numeric lower bounds.
-			;; Make the right decision
-			(let ((av (bound-value a-lo))
-			      (bv (bound-value b-lo)))
-			  (cond ((< av bv)
-				 ;; Obviously
-				 t)
-				((= av bv)
-				 ;; Bounds are equal.  A is lower
-				 ;; unless A is open and B is closed.
-				 (or (numberp a-lo) (consp b-lo)))
-				(t
-				 nil)))))))))
-    (merge-types (stable-sort types #'num-interval-<))))
-
-(defun derive-simple-real-type (x y fun)
-  (declare (type function fun))
-  ;; We handle the case of real operands.  For the other cases, we use
-  ;; general numeric contagion.
-  (if (and (numeric-type-p x) (numeric-type-p y)
-	   (eq (numeric-type-complexp x) :real)
-	   (eq (numeric-type-complexp y) :real))
-      (multiple-value-bind (low high type format)
-	  (funcall fun x y)
-	(flet ((valid-bound-p (bnd)
-		 (or (eq bnd '*)
-		     (eq bnd nil)
-		     (numberp bnd)
-		     (and (consp bnd)
-			  (numberp (first bnd))))))
-	  (assert (and (valid-bound-p low)
-		       (valid-bound-p high)))
-	  (make-numeric-type :class type
-			     :complexp :real
-			     :format format
-			     :low low
-			     :high high)))
-      (numeric-contagion x y)))
 ) ; end progn
 
 
@@ -993,127 +946,137 @@
 
 #+propagate-float-type
 (progn
+(defun +-derive-type-aux (x y same-arg)
+  (if (and (numeric-type-real-p x)
+	   (numeric-type-real-p y))
+      (let ((result
+	     (if same-arg
+		 (let ((x-int (numeric-type->interval x)))
+		   (interval-add x-int x-int))
+		 (interval-add (numeric-type->interval x)
+			       (numeric-type->interval y))))
+	    (result-type (numeric-contagion x y)))
+	;; If the result type is a float, we need to be sure to coerce
+	;; the bounds into the correct type.
+	(when (eq (numeric-type-class result-type) 'float)
+	  (setf result (interval-func
+			#'(lambda (x)
+			    (coerce x (or (numeric-type-format result-type)
+					  'float)))
+			result)))
+	(make-numeric-type
+	 :class (if (and (eq (numeric-type-class x) 'integer)
+			 (eq (numeric-type-class y) 'integer))
+		    ;; The sum of integers is always an integer
+		    'integer
+		    (numeric-type-class result-type))
+	 :format (numeric-type-format result-type)
+	 :low (interval-low result)
+	 :high (interval-high result)))
+      ;; General contagion
+      (numeric-contagion x y)))
+
+
 (defoptimizer (+ derive-type) ((x y))
-  (let ((same-arg (same-leaf-ref-p x y)))
-    (derive-real-type
-     x y
-     #'(lambda (x y)
-	 (declare (type numeric-type x y))
-	 (let ((result
-		(if same-arg
-		    (let ((x-int (numeric-type->interval x)))
-		      (interval-add x-int x-int))
-		    (interval-add (numeric-type->interval x)
-				  (numeric-type->interval y))))
-	       (result-type (numeric-contagion x y)))
-	   ;; If the result type is a float, we need to be sure to
-	   ;; coerce the bounds into the correct type.
-	   (when (eq (numeric-type-class result-type) 'float)
-	     (setf result (interval-func
-			   #'(lambda (x)
-			       (coerce x (or (numeric-type-format result-type)
-					     'float)))
-			   result)))
-	   (values (interval-low result)
-		   (interval-high result)
-		   (if (and (eq (numeric-type-class x) 'integer)
-			    (eq (numeric-type-class y) 'integer))
-		       ;; The sum of integers is always an integer
-		       'integer
-		       (numeric-type-class result-type))
-		   (numeric-type-format result-type)))))))
+  (two-arg-derive-type x y #'+-derive-type-aux))
+
+(defun --derive-type-aux (x y same-arg)
+  (if (and (numeric-type-real-p x)
+	   (numeric-type-real-p y))
+      (let ((result 
+	     ;; (- x x) is always 0.
+	     (if same-arg
+		 (make-interval :low 0 :high 0)
+		 (interval-sub (numeric-type->interval x)
+			       (numeric-type->interval y))))
+	    (result-type (numeric-contagion x y)))
+	;; If the result type is a float, we need to be sure to coerce
+	;; the bounds into the correct type.
+	(when (eq (numeric-type-class result-type) 'float)
+	  (setf result (interval-func
+			#'(lambda (x)
+			    (coerce x (or (numeric-type-format result-type)
+					  'float)))
+			result)))
+	(make-numeric-type
+	 :class (if (and (eq (numeric-type-class x) 'integer)
+			 (eq (numeric-type-class y) 'integer))
+		    ;; The difference of integers is always an integer
+		    'integer
+		    (numeric-type-class result-type))
+	 :format (numeric-type-format result-type)
+	 :low (interval-low result)
+	 :high (interval-high result)))
+      ;; General contagion
+      (numeric-contagion x y)))
 
 (defoptimizer (- derive-type) ((x y))
-  (let ((same-arg (same-leaf-ref-p x y)))
-    (derive-real-type
-     x y
-     #'(lambda (x y)
-	 (declare (type numeric-type x y))
-	 (let ((result 
-		;; (- x x) is always 0.
-		(if same-arg
-		    (make-interval :low 0 :high 0)
-		    (interval-sub (numeric-type->interval x)
-				  (numeric-type->interval y))))
-	       (result-type (numeric-contagion x y)))
-	   ;; If the result type is a float, we need to be sure to
-	   ;; coerce the bounds into the correct type.
-	   (when (eq (numeric-type-class result-type) 'float)
-	     (setf result (interval-func
-			   #'(lambda (x)
-			       (coerce x (or (numeric-type-format result-type)
-					     'float)))
-			   result)))
-	   (values (interval-low result)
-		   (interval-high result)
-		   (if (and (eq (numeric-type-class x) 'integer)
-			    (eq (numeric-type-class y) 'integer))
-		       ;; The difference of integers is always an integer
-		       'integer
-		       (numeric-type-class result-type))
-		   (numeric-type-format result-type)))))))
+  (two-arg-derive-type x y #'--derive-type-aux))
+
+(defun *-derive-type-aux (x y same-arg)
+  (if (and (numeric-type-real-p x)
+	   (numeric-type-real-p y))
+      (let ((result
+	     ;; (* x x) is always positive, so take care to do it
+	     ;; right.
+	     (if same-arg
+		 (interval-sqr (numeric-type->interval x))
+		 (interval-mul (numeric-type->interval x)
+			       (numeric-type->interval y))))
+	    (result-type (numeric-contagion x y)))
+	;; If the result type is a float, we need to be sure to coerce
+	;; the bounds into the correct type.
+	(when (eq (numeric-type-class result-type) 'float)
+	  (setf result (interval-func
+			#'(lambda (x)
+			    (coerce x (or (numeric-type-format result-type)
+					  'float)))
+			result)))
+	(make-numeric-type
+	 :class (if (and (eq (numeric-type-class x) 'integer)
+			 (eq (numeric-type-class y) 'integer))
+		    ;; The product of integers is always an integer
+		    'integer
+		    (numeric-type-class result-type))
+	 :format (numeric-type-format result-type)
+	 :low (interval-low result)
+	 :high (interval-high result)))
+      (numeric-contagion x y)))
 
 (defoptimizer (* derive-type) ((x y))
-  (let ((same-arg (same-leaf-ref-p x y)))
-    (derive-real-type
-     x y
-     #'(lambda (x y)
-	 (let ((result
-		;; (* x x) is always positive, so take care to do it
-		;; right.
-		(if same-arg
-		    (interval-sqr (numeric-type->interval x))
-		    (interval-mul (numeric-type->interval x)
-				  (numeric-type->interval y))))
-	       (result-type (numeric-contagion x y)))
-	 ;; If the result type is a float, we need to be sure to
-	 ;; coerce the bounds into the correct type.
-	 (when (eq (numeric-type-class result-type) 'float)
-	   (setf result (interval-func
-			 #'(lambda (x)
-			     (coerce x (or (numeric-type-format result-type)
-					   'float)))
-			 result)))
-	   (values (interval-low result)
-		   (interval-high result)
-		   (if (and (eq (numeric-type-class x) 'integer)
-			    (eq (numeric-type-class y) 'integer))
-		       ;; The product of integers is always an integer
-		       'integer
-		       (numeric-type-class result-type))
-		   (numeric-type-format result-type)))))))
-
+  (two-arg-derive-type x y #'*-derive-type-aux))
+
+(defun /-derive-type-aux (x y same-arg)
+  (if (and (numeric-type-real-p x)
+	   (numeric-type-real-p y))
+      (let ((result
+	     ;; (/ x x) is always 1, except if x can contain 0.  In
+	     ;; that case, we shouldn't optimize the division away
+	     ;; because we want 0/0 to signal an error.
+	     (if (and same-arg
+		      (not (interval-contains-p
+			    0 (interval-closure (numeric-type->interval y)))))
+		 (make-interval :low 1 :high 1)
+		 (interval-div (numeric-type->interval x)
+			       (numeric-type->interval y))))
+	    (result-type (numeric-contagion x y)))
+	;; If the result type is a float, we need to be sure to coerce
+	;; the bounds into the correct type.
+	(when (eq (numeric-type-class result-type) 'float)
+	  (setf result (interval-func
+			#'(lambda (x)
+			    (coerce x (or (numeric-type-format result-type)
+					  'float)))
+			result)))
+	(make-numeric-type :class (numeric-type-class result-type)
+			   :format (numeric-type-format result-type)
+			   :low (interval-low result)
+			   :high (interval-high result)))
+      (numeric-contagion x y)))
 
 
 (defoptimizer (/ derive-type) ((x y))
-  (let ((same-arg (same-leaf-ref-p x y)))
-    (derive-real-type
-     x y
-     #'(lambda (x y)
-	 (declare (type numeric-type x y))
-	 (let ((result
-		;; (/ x x) is always 1, except if x can contain 0.  In
-		;; that case, we shouldn't optimize the division away
-		;; because we want 0/0 to signal an error.
-		(if (and same-arg
-			 (not (interval-contains-p 0
-						   (interval-closure (numeric-type->interval y)))))
-		    (make-interval :low 1 :high 1)
-		    (interval-div (numeric-type->interval x)
-				  (numeric-type->interval y))))
-	       (result-type (numeric-contagion x y)))
-	   ;; If the result type is a float, we need to be sure to
-	   ;; coerce the bounds into the correct type.
-	   (when (eq (numeric-type-class result-type) 'float)
-	     (setf result (interval-func
-			   #'(lambda (x)
-			       (coerce x (or (numeric-type-format result-type)
-					     'float)))
-			   result)))
-	   (values (interval-low result)
-		   (interval-high result)
-		   (numeric-type-class result-type)
-		   (numeric-type-format result-type)))))))
+  (two-arg-derive-type x y #'/-derive-type-aux))
 
 ) ;end progn
 
@@ -1165,24 +1128,31 @@
     (derive-integer-type int int (frob lognot))))
 
 #+propagate-float-type
-(macrolet ((frob (fun)
-	     `#'(lambda (type type2)
-		  (declare (ignore type2))
-		  (let ((lo (numeric-type-low type))
-			(hi (numeric-type-high type)))
-		    (values (if hi (,fun hi) nil)
-			    (if lo (,fun lo) nil)
-			    (numeric-type-class type)
-			    (numeric-type-format type))))))
-
-  (defoptimizer (%negate derive-type) ((num))
-    (flet ((negate-bound (b)
-	     (set-bound (- (bound-value b)) (consp b))))
-      (derive-real-type num num (frob negate-bound))))
-
-  (defoptimizer (lognot derive-type) ((int))
-    (derive-integer-type int int (frob lognot))))
+(defoptimizer (lognot derive-type) ((int))
+  (derive-integer-type int int
+		       #'(lambda (type type2)
+			   (declare (ignore type2))
+			   (let ((lo (numeric-type-low type))
+				 (hi (numeric-type-high type)))
+			     (values (if hi (lognot hi) nil)
+				     (if lo (lognot lo) nil)
+				     (numeric-type-class type)
+				     (numeric-type-format type))))))
 
+#+propagate-float-type
+(defoptimizer (%negate derive-type) ((num))
+  (flet ((negate-bound (b)
+	   (set-bound (- (bound-value b)) (consp b))))
+    (one-arg-derive-type num
+			 #'(lambda (type)
+			     (let ((lo (numeric-type-low type))
+				   (hi (numeric-type-high type))
+				   (result (copy-numeric-type type)))
+			       (setf (numeric-type-low result)
+				      (if hi (negate-bound hi) nil))
+			       (setf (numeric-type-high result)
+				     (if lo (negate-bound lo) nil))
+			       result)))))
 
 #-propagate-float-type
 (defoptimizer (abs derive-type) ((num))
@@ -1204,44 +1174,29 @@
 				       nil)))
 	(numeric-contagion type type))))
 
-(defun abs-derive-type-aux (type &optional (result '()))
-  (cond ((null type)
-	 result)
-	((atom type)
-	 (cons (cond
-		 ((eq (numeric-type-complexp type) :complex)
-		  ;; The absolute value of a complex number is always
-		  ;; a non-negative float.
-		  (make-numeric-type :class 'float
-				     :format (elfun-float-format
-					      (numeric-type-format type))
-				     :complexp :real
-				     :low 0
-				     :high nil))
-		 ((eq (numeric-type-complexp type) :real)
-		  ;; The absolute value of a real number is a
-		  ;; non-negative real of the same type.
-		  (let ((abs-bnd (interval-abs (numeric-type->interval type))))
-		    (make-numeric-type :class (numeric-type-class type)
-				       :format (numeric-type-format type)
-				       :complexp :real
-				       :low (interval-low abs-bnd)
-				       :high (interval-high abs-bnd)))))
-	       result))
-    ((listp type)
-     (abs-derive-type-aux (rest type)
-			  (append (abs-derive-type-aux (first type))
-				  result)))))
-
+#+propagate-float-type
+(defun abs-derive-type-aux (type)
+  (cond ((eq (numeric-type-complexp type) :complex)
+	 ;; The absolute value of a complex number is always a
+	 ;; non-negative float.
+	 (make-numeric-type :class 'float
+			    :format (elfun-float-format
+				     (numeric-type-format type))
+			    :complexp :real
+			    :low 0
+			    :high nil))
+	(t
+	 ;; The absolute value of a real number is a non-negative real
+	 ;; of the same type.
+	 (let ((abs-bnd (interval-abs (numeric-type->interval type))))
+	   (make-numeric-type :class (numeric-type-class type)
+			      :format (numeric-type-format type)
+			      :complexp :real
+			      :low (interval-low abs-bnd)
+			      :high (interval-high abs-bnd))))))
 #+propagate-float-type
 (defoptimizer (abs derive-type) ((num))
-  (let ((type (continuation-type num)))
-    (cond ((numeric-type-p type)
-	   (first (abs-derive-type-aux type)))
-	  ((union-type-p type)
-	   (make-union-type
-	    (derive-merged-union-types
-	     (abs-derive-type-aux (union-type-types type))))))))
+  (one-arg-derive-type num #'abs-derive-type-aux))
 
 #-propagate-float-type
 (defoptimizer (truncate derive-type) ((number divisor))
@@ -1310,6 +1265,7 @@
 	 ;; are REAL so the result is a REAL.
 	 'real)))
 
+
 (defun truncate-derive-type-quot (number-type divisor-type)
   (let* ((rem-type (rem-result-type number-type divisor-type))
 	 (number-interval (numeric-type->interval number-type))
@@ -1323,24 +1279,14 @@
 			(interval-low number-interval)
 			(interval-high number-interval)
 			(interval-low divisor-interval)
-			(interval-high divisor-interval)))
-		  type lo hi)
-	     (when (listp res)
-	       (setf type (first res))
-	       (setf lo (second res))
-	       (setf hi (third res))
-	       (setf lo (if (or (equal lo ''*) (eq lo '*))
-			    nil lo))
-	       (setf hi (if (or (equal lo ''*) (eq hi '*))
-			    nil hi)))
-	     (values lo hi type nil)))
+			(interval-high divisor-interval))))
+	     (specifier-type (if (listp res) res 'integer))))
 	  (t
 	   (let ((quot (truncate-quotient-bound
 			(interval-div number-interval
 				      divisor-interval))))
-	     (values (interval-low quot)
-		     (interval-high quot)
-		     'integer nil))))))
+	     (specifier-type `(integer ,(or (interval-low quot) '*)
+			               ,(or (interval-high quot) '*))))))))
 
 (defun truncate-derive-type-rem (number-type divisor-type)
   (let* ((rem-type (rem-result-type number-type divisor-type))
@@ -1352,9 +1298,8 @@
     (cond ((eq rem-type 'integer)
 	   ;; Since the remainder type is INTEGER, both args are
 	   ;; INTEGERs.
-	   (values (interval-low rem)
-		   (interval-high rem)
-		   rem-type nil))
+	   (specifier-type `(,rem-type ,(or (interval-low rem) '*)
+			               ,(or (interval-high rem) '*))))
 	  (t
 	   (multiple-value-bind (class format)
 	       (ecase rem-type
@@ -1372,61 +1317,69 @@
 	       (setf rem (interval-func #'(lambda (x)
 					    (coerce x rem-type))
 					rem)))
-	     (values (interval-low rem)
-		     (interval-high rem)
-		     class format))))))
+	     (make-numeric-type :class class
+				:format format
+				:low (interval-low rem)
+				:high (interval-high rem)))))))
+
+(defun truncate-derive-type-quot-aux (num div same-arg)
+  (declare (ignore same-arg))
+  (if (and (numeric-type-real-p num)
+	   (numeric-type-real-p div))
+      (truncate-derive-type-quot num div)
+      *empty-type*))
+
+(defun truncate-derive-type-rem-aux (num div same-arg)
+  (declare (ignore same-arg))
+  (if (and (numeric-type-real-p num)
+	   (numeric-type-real-p div))
+      (truncate-derive-type-rem num div)
+      *empty-type*))
 
 (defoptimizer (truncate derive-type) ((number divisor))
-  (if (and (numeric-real-union-type-p (continuation-type number))
-	   (numeric-real-union-type-p (continuation-type divisor)))
-      (make-values-type
-       :required
-       `(,(derive-real-type number divisor
-			    #'truncate-derive-type-quot)
-	 ,(derive-real-type number divisor
-			    #'truncate-derive-type-rem)))
-      *universal-type*))
+  (make-values-type
+   :required
+   (list
+    (two-arg-derive-type number divisor #'truncate-derive-type-quot-aux)
+    (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux))))
 
 (defun ftruncate-derive-type-quot (number-type divisor-type)
   ;; The bounds are the same as for truncate.  However, the first
   ;; result is a float of some type.  We need to determine what that
   ;; type is.  Basically it's the more contagious of the two types.
-  (multiple-value-bind (lo hi class format)
-      (truncate-derive-type-quot number-type divisor-type)
-    (declare (ignore class format))
-    (let ((res-type (numeric-contagion number-type divisor-type)))
-      (values lo hi (numeric-type-class res-type)
-	      (numeric-type-format res-type)))))
+  (let ((q-type (truncate-derive-type-quot number-type divisor-type))
+	(res-type (numeric-contagion number-type divisor-type)))
+    (make-numeric-type :class 'float
+		       :format (numeric-type-format res-type)
+		       :low (numeric-type-low q-type)
+		       :high (numeric-type-high q-type))))
+
+(defun ftruncate-derive-type-quot-aux (n d same-arg)
+  (declare (ignore same-arg))
+  (if (and (numeric-type-real-p n)
+	   (numeric-type-real-p d))
+      (ftruncate-derive-type-quot n d)
+      *empty-type*))
 
 (defoptimizer (ftruncate derive-type) ((number divisor))
-  (if (and (numeric-real-union-type-p (continuation-type number))
-	   (numeric-real-union-type-p (continuation-type divisor)))
-      (make-values-type
-       :required
-       `(,(derive-real-type number divisor
-			    #'ftruncate-derive-type-quot)
-	 ,(derive-real-type number divisor
-			    #'truncate-derive-type-rem)))
-      *universal-type*))
-  
-;;; Optimizer for %unary-truncate.  We only want the first result of
-;;; truncate (the quotient part of truncate).
-(defoptimizer (%unary-truncate derive-type) ((number))
-  (let ((type (continuation-type number)))
-    (if (numeric-real-union-type-p type)
-	(derive-real-numeric-or-union-type type
-					   (specifier-type '(integer 1 1))
-					   #'truncate-derive-type-quot)
-	*universal-type*)))
+  (make-values-type
+   :required
+   (list
+    (two-arg-derive-type number divisor #'ftruncate-derive-type-quot-aux)
+    (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux))))
 
 
+(defun %unary-truncate-derive-type-aux (number)
+  (truncate-derive-type-quot number (specifier-type '(integer 1 1))))
 
+(defoptimizer (%unary-truncate derive-type) ((number))
+  (one-arg-derive-type number #'%unary-truncate-derive-type-aux))
 
 ;;; Define optimizers for floor and ceiling
 (macrolet
     ((frob-opt (name q-name r-name)
-       (let ((q-aux (intern (concatenate 'string (symbol-name q-name) "-AUX")))
-	     (r-aux (intern (concatenate 'string (symbol-name r-name) "-AUX"))))
+       (let ((q-aux (symbolicate q-name "-AUX"))
+	     (r-aux (symbolicate r-name "-AUX")))
 	 `(progn
 	   ;; Compute type of quotient (first) result
 	   (defun ,q-aux (number-type divisor-type)
@@ -1436,16 +1389,14 @@
 		     (numeric-type->interval divisor-type))
 		    (quot (,q-name (interval-div number-interval
 						 divisor-interval))))
-	       (values (interval-low quot)
-		       (interval-high quot)
-		       'integer nil)))
+	       (specifier-type `(integer ,(or (interval-low quot) '*)
+				         ,(or (interval-high quot) '*)))))
 	   ;; Compute type of remainder
 	   (defun ,r-aux (number-type divisor-type)
 	     (let* ((divisor-interval
 		     (numeric-type->interval divisor-type))
 		    (rem (,r-name divisor-interval))
-		    (result-type (rem-result-type number-type
-						  divisor-type)))
+		    (result-type (rem-result-type number-type divisor-type)))
 	       (multiple-value-bind (class format)
 		   (ecase result-type
 		     (integer
@@ -1458,27 +1409,35 @@
 		      (values 'float nil))
 		     (real
 		      (values nil nil)))
-		 (when (member result-type
-			       '(float single-float double-float))
+		 (when (member result-type '(float single-float double-float))
 		   ;; Make sure the limits on the interval have
 		   ;; the right type.
 		   (setf rem (interval-func #'(lambda (x)
 						(coerce x result-type))
 					    rem)))
-		 (values (interval-low rem)
-			 (interval-high rem)
-			 class format))))
+		 (make-numeric-type :class class
+				    :format format
+				    :low (interval-low rem)
+				    :high (interval-high rem)))))
 	   ;; The optimizer itself
 	   (defoptimizer (,name derive-type) ((number divisor))
-	     (if (and (numeric-real-union-type-p (continuation-type number))
-		      (numeric-real-union-type-p (continuation-type divisor)))
-		 (make-values-type
-		  :required
-		  `(,(derive-real-type number divisor
-				       #',q-aux)
-		    ,(derive-real-type number divisor
-				       #',r-aux)))
-		 *universal-type*))))))
+	     (flet ((derive-q (n d same-arg)
+		      (declare (ignore same-arg))
+		      (if (and (numeric-type-real-p n)
+			       (numeric-type-real-p d))
+			  (,q-aux n d)
+			  *empty-type*))
+		    (derive-r (n d same-arg)
+		      (declare (ignore same-arg))
+		      (if (and (numeric-type-real-p n)
+			       (numeric-type-real-p d))
+			  (,r-aux n d)
+			  *empty-type*)))
+	       (make-values-type
+		:required
+		(list (two-arg-derive-type number divisor #'derive-q)
+		      (two-arg-derive-type number divisor #'derive-r)))))
+	   ))))
   
   (frob-opt floor floor-quotient-bound floor-rem-bound)
   (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound))
@@ -1486,13 +1445,8 @@
 ;;; Define optimizers for ffloor and fceiling
 (macrolet
     ((frob-opt (name q-name r-name)
-       (let ((q-aux (intern (concatenate 'string
-					 "F"
-					 (symbol-name q-name)
-					 "-AUX")))
-	     (r-aux (intern (concatenate 'string
-					 (symbol-name r-name)
-					 "-AUX"))))
+       (let ((q-aux (symbolicate "F" q-name "-AUX"))
+	     (r-aux (symbolicate r-name "-AUX")))
 	 `(progn
 	   ;; Compute type of quotient (first) result
 	   (defun ,q-aux (number-type divisor-type)
@@ -1503,21 +1457,29 @@
 		    (quot (,q-name (interval-div number-interval
 						 divisor-interval)))
 		    (res-type (numeric-contagion number-type divisor-type)))
-	       (values (interval-low quot)
-		       (interval-high quot)
-		       (numeric-type-class res-type)
-		       (numeric-type-format res-type))))
-
+	       (make-numeric-type
+		:class (numeric-type-class res-type)
+		:format (numeric-type-format res-type)
+		:low  (interval-low quot)
+		:high (interval-high quot))))
+	   
 	   (defoptimizer (,name derive-type) ((number divisor))
-	     (if (and (numeric-real-union-type-p (continuation-type number))
-		      (numeric-real-union-type-p (continuation-type divisor)))
-		 (make-values-type
-		  :required
-		  `(,(derive-real-type number divisor
-				       #',q-aux)
-		    ,(derive-real-type number divisor
-				       #',r-aux)))
-		 *universal-type*))))))
+	     (flet ((derive-q (n d same-arg)
+		      (declare (ignore same-arg))
+		      (if (and (numeric-type-real-p n)
+			       (numeric-type-real-p d))
+			  (,q-aux n d)
+			  *empty-type*))
+		    (derive-r (n d same-arg)
+		      (declare (ignore same-arg))
+		      (if (and (numeric-type-real-p n)
+			       (numeric-type-real-p d))
+			  (,r-aux n d)
+			  *empty-type*)))
+	       (make-values-type
+		:required
+		(list (two-arg-derive-type number divisor #'derive-q)
+		      (two-arg-derive-type number divisor #'derive-r)))))))))
   
   (frob-opt ffloor floor-quotient-bound floor-rem-bound)
   (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))
@@ -1532,10 +1494,9 @@
 	(hi (interval-high quot)))
     ;; Take the floor of the lower bound.  The result is always a
     ;; closed lower bound.
-    (setf lo
-	  (if lo
-	      (floor (bound-value lo))
-	      nil))
+    (setf lo (if lo
+		 (floor (bound-value lo))
+		 nil))
     ;; For the upper bound, we need to be careful
     (setf hi
 	  (cond ((consp hi)
@@ -1557,14 +1518,16 @@
 (defun floor-rem-bound (div)
   ;; The remainder depends only on the divisor.  Try to get the
   ;; correct sign for the remainder if we can.
-
+  
   (case (interval-range-info div)
     (+
      ;; Divisor is always positive.  
      (let ((rem (interval-abs div)))
        (setf (interval-low rem) 0)
-       (when (numberp (interval-high rem))
-	 ;; The remainder never contains the upper bound.
+       (when (and (numberp (interval-high rem))
+		  (not (zerop (interval-high rem))))
+	 ;; The remainder never contains the upper bound.  However,
+	 ;; watch out for the case where the high limit is zero!
 	 (setf (interval-high rem) (list (interval-high rem))))
        rem))
     (-
@@ -1629,10 +1592,9 @@
 	(hi (interval-high quot)))
     ;; Take the ceiling of the upper bound.  The result is always a
     ;; closed upper bound.
-    (setf hi
-	  (if hi
-	      (ceiling (bound-value hi))
-	      nil))
+    (setf hi (if hi
+		 (ceiling (bound-value hi))
+		 nil))
     ;; For the lower bound, we need to be careful
     (setf lo
 	  (cond ((consp lo)
@@ -1655,14 +1617,16 @@
 (defun ceiling-rem-bound (div)
   ;; The remainder depends only on the divisor.  Try to get the
   ;; correct sign for the remainder if we can.
-
+  
   (case (interval-range-info div)
     (+
      ;; Divisor is always positive.  The remainder is negative.
      (let ((rem (interval-neg (interval-abs div))))
        (setf (interval-high rem) 0)
-       (when (numberp (interval-low rem))
-	 ;; The remainder never contains the upper bound.
+       (when (and (numberp (interval-low rem))
+		  (not (zerop (interval-low rem))))
+	 ;; The remainder never contains the upper bound.  However,
+	 ;; watch out for the case when the upper bound is zero!
 	 (setf (interval-low rem) (list (interval-low rem))))
        rem))
     (-
@@ -1764,11 +1728,9 @@
     (-
      (case (interval-range-info div)
        (+
-	(ceiling-rem-bound div)
-	)
+	(ceiling-rem-bound div))
        (-
-	(floor-rem-bound div)
-	)
+	(floor-rem-bound div))
        (otherwise
 	(destructuring-bind (neg pos)
 	    (interval-split 0 div t t)
@@ -1816,7 +1778,7 @@
 	;; We've got a problem: guarenteed division by zero.
 	(return-from integer-truncate-derive-type t))
       (when (zerop divisor-min)
-	;; We'll assume that they arn't going to divide by zero.
+	;; We'll assume that they aren't going to divide by zero.
 	(incf divisor-min))
       (cond ((and number-sign divisor-sign)
 	     ;; We know the sign of both.
-- 
GitLab