diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index b68444ba62607aec65ff64c0f24894e07a76ee07..ad6cecfc9f6946d551e7b0efffe962dd305deb1a 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 1301148d6849a99664da816a7a9b8a9e90dc7f5c..93470a95308f5d977b674efc34176b3ba9de2061 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.