diff --git a/compiler/constraint.lisp b/compiler/constraint.lisp
index a331e569f53b6c84418ecf8a325c1b2b0eb39dfd..fb29146d865406f645f6d3d53d60d533abfa06f5 100644
--- a/compiler/constraint.lisp
+++ b/compiler/constraint.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/constraint.lisp,v 1.16 1997/01/18 14:31:31 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.17 1997/02/12 22:12:29 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -321,19 +321,36 @@
 ;;;
 (defun constrain-float-type (x y greater or-equal)
   (declare (type numeric-type x y))
-  (flet ((exclude (x)
-	   (cond ((not x) nil)
-		 (or-equal x)
-		 (greater
-		  (if (consp x)
-		      (car x)
-		      x))
-		 (t
-		  (if (consp x)
-		      x
-		      (list x)))))
-	 (bound (x)
-	   (if greater (numeric-type-low x) (numeric-type-high x))))
+  (labels ((exclude (x)
+	     (cond ((not x) nil)
+		   (or-equal x)
+		   (greater
+		    (if (consp x)
+			(car x)
+			x))
+		   (t
+		    (if (consp x)
+			x
+			(list x)))))
+	   (bound (x)
+	     (if greater (numeric-type-low x) (numeric-type-high x)))
+	   (max-lower-bound (x y)
+	     ;; Both x and y are not null.  Find the max.
+	     (let ((res (max (bound-value x) (bound-value y))))
+	       ;; An open lower bound is greater than a close
+	       ;; lower bound because the open bound doesn't
+	       ;; contain the bound, so choose an open lower
+	       ;; bound.
+	       (set-bound res (or (consp x) (consp y)))))
+	   (min-upper-bound (x y)
+	     ;; Same as above, but for the min of upper bounds
+	     ;; Both x and y are not null.  Find the min.
+	     (let ((res (min (bound-value x) (bound-value y))))
+	       ;; An open upper bound is less than a closed
+	       ;; upper bound because the open bound doesn't
+	       ;; contain the bound, so choose an open lower
+	       ;; bound.
+	       (set-bound res (or (consp x) (consp y))))))
     #+nil
     (format t "~%constraint-float-type:~%  ~s~%  ~s~%  ~s~%  ~s~%"
 	    x y greater or-equal)
@@ -344,9 +361,9 @@
 			    ((not y-bound)
 			     x-bound)
 			    (greater
-			     (max-bound x-bound y-bound))
+			     (max-lower-bound x-bound y-bound))
 			    (t
-			     (min-bound x-bound y-bound))))
+			     (min-upper-bound x-bound y-bound))))
 	   (res (copy-numeric-type x)))
       #+nil
       (format t "x-bound, y-bound, new-bound = ~s, ~s, ~s~%"
diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index b3332dda3a8ed3d26daffcbe4e4127709d48778c..ba1ef4739fe3b4f81ecaedf38a0bc0d90e874f3a 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.25 1997/02/05 15:41:50 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.26 1997/02/12 22:12:24 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -318,8 +318,7 @@
 		 (acos (real -1.0 1.0))
 		 (acosh (real 1.0))
 		 (atanh (real -1.0 1.0))
-		 (sqrt (real 0.0))
-		 ))
+		 (sqrt (real 0.0))))
   (destructuring-bind (name type) stuff
     (let ((type (specifier-type type)))
       (setf (function-info-derive-type (function-info-or-lose name))
@@ -452,41 +451,18 @@
     (deftransform name ((x y) '(double-float double-float)
 			rtype :eval-name t :when :both)
       `(,prim x y))))
-#+nil
-(deftransform log ((x y) (float float) float)
-  '(/ (log x) (log y)))
 
 ;;; ANSI says log with base zero returns zero.
 (deftransform log ((x y) (float float) float)
   '(if (zerop y) y (/ (log x) (log y))))
 
 
-;;; Return the float format of the result of an elementary function.
-;;; If the format is NIL (which means type FLOAT), we return NIL.  If
-;;; the format is 'DOUBLE-FLOAT, we return that.  For any other case,
-;;; we return 'SINGLE-FLOAT.
-  
-(proclaim '(inline elfun-format numeric-type-real-p))  
-(defun elfun-float-format (format)
-  (if format
-      (if (eq format 'double-float)
-	  'double-float
-	  'single-float)))
-
-#+propagate-fun-type
-(progn
-;;;; Optimizers for elementary functions
-;;;;
-;;;; These optimizers compute the output range of the elementary
-;;;; function, based on the domain of the input.
-;;;;
-
 ;;; Handle some simple transformations
   
 (deftransform abs ((x) ((complex double-float)) double-float :when :both)
   '(%hypot (realpart x) (imagpart x)))
 
-(deftransform abs ((x) ((complex single-float)) single-float :when :both)
+(deftransform abs ((x) ((complex single-float)) single-float)
   '(coerce (%hypot (coerce (the single-float (realpart x)) 'double-float)
 		  (coerce (the single-float (imagpart x)) 'double-float))
 	  'single-float))
@@ -494,7 +470,7 @@
 (deftransform phase ((x) ((complex double-float)) double-float :when :both)
   '(%atan2 (imagpart x) (realpart x)))
 
-(deftransform phase ((x) ((complex single-float)) single-float :when :both)
+(deftransform phase ((x) ((complex single-float)) single-float)
   '(coerce (%atan2 (coerce (the single-float (imagpart x)) 'double-float)
 		  (coerce (the single-float (realpart x)) 'double-float))
 	  'single-float))
@@ -504,9 +480,17 @@
       (float pi x)
       (float 0 x)))
 
+#+propagate-fun-type
+(progn
+;;;; Optimizers for elementary functions
+;;;;
+;;;; These optimizers compute the output range of the elementary
+;;;; function, based on the domain of the input.
+;;;;
 
 ;;; The number is of type REAL.
 
+(proclaim '(inline numeric-type-real-p))
 (defun numeric-type-real-p (type)
   (and (numeric-type-p type)
        (eq (numeric-type-complexp type) :real)))
@@ -547,16 +531,22 @@
 
 		     ;; The call to the limit-fun has (most) traps
 		     ;; disabled.  It can naively compute the result,
-		     ;; but it must call set-bound to make sure any
-		     ;; overflow is converted to NIL appropriately.
+		     ;; and return infinity for the value.  We convert
+		     ;; the infinity to nil, as needed.
 		     (multiple-value-bind (,lo-lim ,hi-lim)
 			 (funcall ,limit-fun lo hi)
 		       (make-numeric-type :class 'float
 					  :format (elfun-float-format
 						   (numeric-type-format ,type))
 					  :complexp :real
-					  :low ,lo-lim
-					  :high ,hi-lim)))
+					  :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))))
 		;; Restore the floating-point modes
 		(apply #'set-floating-point-modes ,fp-mode)
 		))))))))
@@ -576,14 +566,8 @@
 		      ;; lower bound and the upper bound are the values
 		      ;; of the function at the bounds of the input
 		      ;; range.
-		      (values (if ,lo-bnd
-				  (set-bound (,name (bound-value ,lo-bnd))
-					     (consp ,lo-bnd))
-				  ,def-lo-bnd)
-			      (if ,hi-bnd
-				  (set-bound (,name (bound-value ,hi-bnd))
-					     (consp ,hi-bnd))
-				  ,def-hi-bnd))))))))
+		      (values (or (bound-func #',name ,lo-bnd) ,def-lo-bnd)
+			      (or (bound-func #',name ,hi-bnd) ,def-hi-bnd))))))))
 
   ;; These functions are easy because they are defined for the whole
   ;; real line.
@@ -593,7 +577,7 @@
   (frob asinh t nil nil)
 
   ;; These functions are only defined for part of the real line.  The
-  ;; condition selectes the desired part of the line.
+  ;; condition selects the desired part of the line.
   (frob sqrt (and lo
 		  (>= (bound-value lo) 0))
 	0 nil)
@@ -606,8 +590,8 @@
   (frob atanh (and lo hi
 		   (>= (bound-value lo) -1)
 		   (<= (bound-value hi) 1))
-	-1 1)
-  )
+	-1 1))
+
 
 ;;; acos is monotonic decreasing, so we need to swap the function
 ;;; values at the lower and upper bounds of the input domain.
@@ -618,10 +602,8 @@
 	(>= (bound-value lo) -1)
 	(<= (bound-value hi) 1))
    #'(lambda (lo hi)
-       (values (if hi
-		   (set-bound (acos (bound-value hi)) (consp hi)))
-	       (if lo
-		   (set-bound (acos (bound-value lo)) (consp lo)))))))
+       (values (bound-func #'acos hi)
+	       (bound-func #'acos lo)))))
 
 ;;; Compute return type for EXPT.  No bounds are computed because
 ;;; that's pretty complicated in general.  We only return a lower
@@ -745,13 +727,10 @@
 	      y
 	      t
 	      #'(lambda (lo hi)
-		  (values (if lo
-			      (set-bound (atan (bound-value lo)) (consp lo))
-			      #.(- (/ pi 2)))
-			  (if hi
-			      (set-bound (atan (bound-value hi)) (consp hi))
-			      #.(/ pi 2))))))))))
+		  (values (or (bound-func #'atan lo) #.(- (/ pi 2)))
+			  (or (bound-func #'atan hi) #.(/ pi 2))))))))))
 
+#+nil
 (defoptimizer (cosh derive-type) ((num))
   (let ((type (continuation-type num)))
     (when (numeric-type-real-p type)
@@ -791,6 +770,17 @@
 	    ;; Restore the floating-point modes
 	    (apply #'set-floating-point-modes fp-modes)))))))
 
+(defoptimizer (cosh derive-type) ((num))
+  (elfun-derive-type
+   num 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)))))))
+
+#+nil
 (defoptimizer (phase derive-type) ((num))
   (let ((type (continuation-type num)))
     (cond ((numeric-type-real-p type)
@@ -835,21 +825,71 @@
 			      :complexp :real
 			      :low #.(- pi)
 			      :high pi)))))
+
+(defoptimizer (phase derive-type) ((num))
+  (let ((type (continuation-type num)))
+    ;; Warning: This optimizer doesn't yet handle the case of -0.0.
+    ;; It returns 0 for this case instead of pi.  Need to fix this.
+    (cond ((numeric-type-real-p type)
+	   (case (interval-range-info (numeric-type->interval type))
+	     ('+
+	      ;; The number is positive, so the phase is 0.
+	      (make-numeric-type :class 'float
+				 :format (elfun-float-format
+					  (numeric-type-format type))
+				 :complexp :real
+				 :low 0
+				 :high 0))
+	     ('-
+	      ;; The number is always negative, so the phase is pi
+	      (make-numeric-type :class 'float
+				 :format (elfun-float-format
+					  (numeric-type-format type))
+				 :complexp :real
+				 :low pi
+				 :high pi))
+	     (t
+	      ;; We can't tell.  The result is 0 or pi.  Use a union type for this
+	      (make-union-type
+	       (list
+		(make-numeric-type :class 'float
+				   :format (elfun-float-format
+					    (numeric-type-format type))
+				   :complexp :real
+				   :low 0
+				   :high 0)
+		(make-numeric-type :class 'float
+				   :format (elfun-float-format
+					    (numeric-type-format type))
+				   :complexp :real
+				   :low pi
+				   :high pi))))))
+	  (t
+	   ;; We have a complex number.  The answer is the range -pi
+	   ;; to pi.  (-pi is included because we have -0.)
+	   (make-numeric-type :class 'float
+			      :format (elfun-float-format
+				       (numeric-type-format type))
+			      :complexp :real
+			      :low #.(- pi)
+			      :high pi)))))
 		 
+) ;end progn for propagate-fun-type
+
 ;;; Make REALPART and IMAGPART return the appropriate types.  This
 ;;; helps a lot in optimized code.
 
+;;; Doesn't work yet.
 #+nil
+(progn
 (defknown (%realpart)
     (complex) real
     (flushable movable))
 
-#+nil
 (defknown (%imagpart)
     (complex) real
     (flushable movable))
 
-#+nil
 (defoptimizer (%realpart derive-type) ((num))
   (let ((type (continuation-type num)))
     (cond ((numeric-type-real-p type)
@@ -869,7 +909,6 @@
 			      :low (numeric-type-low type)
 			      :high (numeric-type-high type))))))
 
-#+nil
 (defoptimizer (%imagpart derive-type) ((num))
   (let ((type (continuation-type num)))
     (cond ((numeric-type-real-p type)
diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp
index 6093358988f8562715228b5f1bf592b85f9cb18a..26c4265445ed976401b88a98b01604e737fcedca 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.47 1997/02/05 15:41:57 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.48 1997/02/12 22:12:27 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -228,6 +228,464 @@
 	   (t
 	    0))))
 
+
+;;;; Interval arithmetic for computing bounds
+;;;; (toy@rtp.ericsson.se)
+;;;;
+;;;; This is a set of routines for operating on intervals.  It
+;;;; implements a simple interval arithmetic package.  Although CMUCL
+;;;; has an interval type in numeric-type, we choose to use our own
+;;;; for two reasons:
+;;;;
+;;;;   1.  This package is simpler than numeric-type
+;;;;
+;;;;   2.  It makes debugging much easier because you can just strip
+;;;;   out these routines and test them independently of CMUCL.  (A
+;;;;   big win!)
+;;;;
+;;;; One disadvantage is a probable increase in consing because we
+;;;; have to create these new interval structures even though
+;;;; numeric-type has everything we want to know.  Reason 2 wins for
+;;;; now.
+
+
+#+propagate-float-type
+(progn
+
+(defun elfun-float-format (format)
+  (if format
+      (if (eq format 'double-float)
+	  'double-float
+	  'single-float)))
+
+  
+;;; The basic interval type.  It can handle open and closed intervals.
+;;; A bound is open if it is a list containing a number, just like
+;;; Lisp says.  NIL means unbounded.
+(defstruct interval
+  low high)
+
+(proclaim '(inline bound-value set-bound bound-func))
+
+;;; Extract the numeric value of a bound.  Return NIL, if X is NIL.
+(defun bound-value (x)
+  (if (consp x) (car x) x))
+
+;;; Given a number X, create a form suitable as a bound for an
+;;; interval.  Make the bound open if OPEN-P is T.  NIL remains NIL.
+(defun set-bound (x open-p)
+  (if (and x open-p) (list x) x))
+
+;;; Apply the function F to a bound X.  If X is an open bound, then
+;;; the result will be open.  IF X is NIL, the result is NIL.
+(defun bound-func (f x)
+  (and x
+        (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
+;;; is open if either X or Y is open.
+(defmacro bound-binop (op x y)
+  `(and ,x ,y
+        (set-bound (,op (bound-value ,x)
+		        (bound-value ,y))
+	           (or (consp ,x) (consp ,y)))))
+
+;;; NUMERIC-TYPE->INTERVAL
+;;;
+;;; Convert a numeric-type object to an interval object.
+
+(defun numeric-type->interval (x)
+  (declare (type numeric-type x))
+  (make-interval :low (numeric-type-low x)
+		 :high (numeric-type-high x)))
+
+;;; INTERVAL-SPLIT
+;;;
+;;; Given a point P contained in the interval X, split X into two
+;;; interval at the point P.  If JOIN-LOWER it T, then the left
+;;; interval contains P.  Otherwise, the right interval contains P.
+;;; You can specify both to be T.
+
+(defun interval-split (p x &optional close-lower close-upper)
+  (declare (type number p)
+	   (type interval x))
+  (list (make-interval :low (interval-low x)
+		       :high (if close-lower p (list p)))
+	(make-interval :low (if close-upper (list p) p)
+		       :high (interval-high x))))
+
+(defun interval-closure (x)
+  (declare (type interval x))
+  (make-interval :low (bound-value (interval-low x))
+		 :high (bound-value (interval-high x))))
+
+;;; INTERVAL-RANGE-INFO
+;;;
+;;; For an interval X, if X >= 0, return '+.  If X <= 0, return
+;;; '-. Otherwise return NIL.
+
+(defun interval-range-info (x)
+  (declare (type interval x))
+  (let ((lo (interval-low x))
+	(hi (interval-high x)))
+  (cond ((and lo (>= (bound-value lo) 0))
+	 '+)
+	((and hi (<= (bound-value hi) 0))
+	 '-)
+	(t
+	 nil))))
+
+;;; INTERVAL-BOUNDED-P
+;;;
+;;; Test to see if the interval X is bounded.  HOW determines the
+;;; test, and should be either ABOVE, BELOW, or BOTH.
+
+(defun interval-bounded-p (x how)
+  (declare (type interval x))
+  (ecase how
+    ('above
+     (interval-high x))
+    ('below
+     (interval-low x))
+    ('both
+     (and (interval-low x) (interval-high x)))))
+
+;;; INTERVAL-CONTAINS-P
+;;;
+;;; See if the interval X contains the number P, taking into account
+;;; that the interval might not be closed.
+
+(defun interval-contains-p (p x)
+  (declare (type number p)
+	   (type interval x))
+  ;; Does the interval X contain the number P?  This would be a lot
+  ;; easier if all intervals were closed!
+  (let ((lo (interval-low x))
+	(hi (interval-high x)))
+    (cond ((and lo hi)
+	   ;; The interval is bounded
+	   (if (<= (bound-value lo) p (bound-value hi))
+	       ;; P is definitely in the closure of the interval.
+	       ;; We just need to check the end points now.
+	       (cond ((= p (bound-value lo))
+		      (numberp lo))
+		     ((= p (bound-value hi))
+		      (numberp hi))
+		     (t t))
+	       nil))
+	  (hi
+	   ;; Interval with upper bound
+	   (if (< p (bound-value hi))
+	       t
+	       (and (numberp hi) (= p hi))))
+	  (lo
+	   ;; Interval with lower bound
+	   (if (> p (bound-value lo))
+	       t
+	       (and (numberp lo) (= p lo))))
+	  (t
+	   ;; Interval with no bounds
+	   t))))
+
+;;; INTERVAL-INTERSECT-P
+;;;
+;;; Determine if two intervals X and Y intersect.  Return T if so.  If
+;;; CLOSED-INTERVALS-P is T, the treat the intervals as if they were
+;;; closed.  Otherwise the intervals are treated as they are.
+;;;
+;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
+;;; because no element in X is in Y.  However, if CLOSED-INTERVALS-P
+;;; is T, then they do intersect because we use the closure of X = [0,
+;;; 1] and Y = [1, 2] to determine intersection.
+
+(defun interval-intersect-p (x y &optional closed-intervals-p)
+  (declare (type interval x y))
+  (let ((x-lo (interval-low x))
+	(x-hi (interval-high x))
+	(y-lo (interval-low y))
+	(y-hi (interval-high y)))
+    (labels ((test-number (p int)
+	       ;; Test if P is in the interval.
+	       (when (interval-contains-p (bound-value p)
+					  (interval-closure int))
+		 (let ((lo (interval-low int))
+		       (hi (interval-high int)))
+		   ;; Check for endpoints
+		   (cond ((or (null lo) (null hi))
+			  t)
+			 ((= (bound-value p) (bound-value lo))
+			  (or closed-intervals-p
+			      (not (and (consp p) (numberp lo)))))
+			 ((= (bound-value p) (bound-value hi))
+			  (or closed-intervals-p
+			      (not (and (numberp p) (consp hi)))))
+			 (t t)))))
+	     (test-lower-bound (p int)
+	       ;; P is a lower bound of an interval.
+	       (if p
+		   (test-number p int)
+		   (not (interval-bounded-p int 'below))))
+	     (test-upper-bound (p int)
+	       ;; P is an upper bound of an interval
+	       (if p
+		   (test-number p int)
+		   (not (interval-bounded-p int 'above))))
+	     )
+      (or (test-lower-bound x-lo y)
+	  (test-upper-bound x-hi y)
+	  (test-lower-bound y-lo x)
+	  (test-upper-bound y-hi x)))))
+
+;;; Are the two intervals adjacent?  That is, is there a number
+;;; between the two intervals that is not an element of either
+;;; interval?  If so, they are not adjacent.  For example [0, 1) and
+;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
+;;; between both intervals.
+(defun interval-adjacent-p (x y)
+  (declare (type interval x y))
+  (flet ((adjacent (lo hi)
+	   ;; Check to see if lo and hi are adjacent.  If either is
+	   ;; nil, they can't be adjacent.
+	   (when (and lo hi (= (bound-value lo) (bound-value hi)))
+	     ;; The bounds are equal.  They are adjacent if one of
+	     ;; them is closed (a number).  If both are open (consp),
+	     ;; then there is a number that lies between them.
+	     (or (numberp lo) (numberp hi)))))
+    (or (adjacent (interval-low y) (interval-high x))
+	(adjacent (interval-low x) (interval-high y)))))
+
+;;; INTERVAL-MERGE-PAIR
+;;;
+;;; If intervals X and Y intersect, return a new interval that is the
+;;; union of the two.  If they do not intersect, return NIL.
+
+(defun interval-merge-pair (x y)
+  (declare (type interval x y))
+  ;; If x and y intersect or are adjacent, create the union.
+  ;; Otherwise return nil
+  (when (or (interval-intersect-p x y)
+	     (interval-adjacent-p x y))
+    (flet ((select-bound (x1 x2 min-op max-op)
+	     (let ((x1-val (bound-value x1))
+		   (x2-val (bound-value x2)))
+	       (cond ((and x1 x2)
+		      ;; Both bounds are finite.  Select the right one.
+		      (cond ((funcall min-op x1-val x2-val)
+			     ;; x1 definitely better
+			     x1)
+			    ((funcall max-op x1-val x2-val)
+			     ;; x2 definitely better
+			     x2)
+			    (t
+			     ;; Bounds are equal.  Select either
+			     ;; value and make it open only if
+			     ;; both were open.
+			     (set-bound x1-val (and (consp x1) (consp x2))))))
+		     (t
+		      ;; At least one bound is not finite.  The
+		      ;; non-finite bound always wins.
+		      nil)))))
+      (let* ((x-lo (interval-low x))
+	     (x-hi (interval-high x))
+	     (y-lo (interval-low y))
+	     (y-hi (interval-high y)))
+	(make-interval :low (select-bound x-lo y-lo #'< #'>)
+		       :high (select-bound x-hi y-hi #'> #'<))))))
+
+;;; Basic arithmetic operations on intervals
+
+;;; INTERVAL-NEG
+;;;
+;;; The negative of an interval
+
+(defun interval-neg (x)
+  (declare (type interval x))
+  (make-interval :low (bound-func #'- (interval-high x))
+		 :high (bound-func #'- (interval-low x))))
+		       
+;;; INTERVAL-ADD
+;;;
+;;; Add two intervals
+
+(defun interval-add (x y)
+  (declare (type interval x y))
+  (make-interval :low (bound-binop + (interval-low x) (interval-low y))
+		 :high (bound-binop + (interval-high x) (interval-high y))))
+
+;;; INTERVAL-SUB
+;;;
+;;; Subtract two intervals
+
+(defun interval-sub (x y)
+  (declare (type interval x y))
+  (make-interval :low (bound-binop - (interval-low x) (interval-high y))
+		 :high (bound-binop - (interval-high x) (interval-low y))))
+
+;;; INTERVAL-MUL
+;;;
+;;; Multiply two intervals
+(defun interval-mul (x y)
+  (declare (type interval x y))
+  (flet ((bound-mul (x y)
+	   (cond ((or (null x) (null y))
+		  ;; Multiply by infinity is infinity
+		  nil)
+		 ((or (and (numberp x) (zerop x))
+		      (and (numberp y) (zerop y)))
+		  ;; Multiply by closed zero is special.  The result is
+		  ;; always a closed bound
+		  0)
+		 ((or (and (floatp x) (float-infinity-p x))
+		      (and (floatp y) (float-infinity-p y)))
+		  ;; Infinity times anything is infinity
+		  nil)
+		 (t
+		  ;; General multiply.  The result is open if either is open.
+		  (bound-binop * x y)))))
+    (let ((x-range (interval-range-info x))
+	  (y-range (interval-range-info y)))
+      (cond ((null x-range)
+	     ;; Split x into two and multiply each separately
+	     (destructuring-bind (x- x+)
+		 (interval-split 0 x t t)
+	       (interval-merge-pair (interval-mul x- y)
+				    (interval-mul x+ y))))
+	    ((null y-range)
+	     ;; Split y into two and multiply each separately
+	     (destructuring-bind (y- y+)
+		 (interval-split 0 y t t)
+	       (interval-merge-pair (interval-mul x y-)
+				    (interval-mul x y+))))
+	    ((eq x-range '-)
+	     (interval-neg (interval-mul (interval-neg x) y)))
+	    ((eq y-range '-)
+	     (interval-neg (interval-mul x (interval-neg y))))
+	    ((and (eq x-range '+) (eq y-range '+))
+	     ;; If we are here, X and Y are both positive
+	     (make-interval :low (bound-mul (interval-low x) (interval-low y))
+			    :high (bound-mul (interval-high x) (interval-high y))))
+	    (t
+	     (error "This shouldn't happen!"))))))
+
+;;; INTERVAL-DIV
+;;;
+;;; Divide two intervals.
+
+
+(defun interval-div (top bot)
+  (declare (type interval top bot))
+  (flet ((bound-div (x y)
+	 ;; Compute x/y
+	 (cond ((null y)
+		;; Divide by infinity means result is 0
+		0)
+	       ((zerop (bound-value y))
+		;; Divide by zero means result is infinity
+		nil)
+	       ((and (numberp x) (zerop x))
+		;; Zero divided by anything is zero.
+		x)
+	       (t
+		(bound-binop / x y)))))
+	       
+    (let ((top-range (interval-range-info top))
+	  (bot-range (interval-range-info bot)))
+      (cond ((null bot-range)
+	     ;; The denominator contains zero, so anything goes!
+	     (make-interval :low nil :high nil))
+	    ((eq bot-range '-)
+	     ;; Denominator is negative so flip the sign, compute the
+	     ;; result, and flip it back.
+	     (interval-neg (interval-div top (interval-neg bot))))
+	    ((null top-range)
+	     ;; Split top into two positive and negative parts, and
+	     ;; divide each separately
+	     (destructuring-bind (top- top+)
+		 (interval-split 0 top t t)
+	       (interval-merge-pair (interval-div top- bot)
+				    (interval-div top+ bot))))
+	    ((eq top-range '-)
+	     ;; Top is negative so flip the sign, divide, and flip the
+	     ;; sign of the result.
+	     (interval-neg (interval-div (interval-neg top) bot)))
+	    ((and (eq top-range '+) (eq bot-range '+))
+	     ;; The easy case
+	     (make-interval :low (bound-div (interval-low top) (interval-high bot))
+			    :high (bound-div (interval-high top) (interval-low bot))))
+	    
+	    (t
+	     (error "This shouldn't happen!"))))))
+
+
+;;; INTERVAL-FUNC
+;;;
+;;; Apply the function F to the interval X.  If X = [a, b], then the
+;;; result is [f(a), f(b)].  It is up to the user to make sure the
+;;; result makes sense.  It will if F is monotonic increasing (or
+;;; non-decreasing).
+
+(defun interval-func (f x)
+  (declare (type interval x))
+  (let ((lo (bound-func f (interval-low x)))
+	(hi (bound-func f (interval-high x))))
+    (make-interval :low lo :high hi)))
+
+;;; INTERVAL-<
+;;;
+;;; Return T if X < Y.  That is every number in the interval X is
+;;; always less than any number in the interval Y.
+
+(defun interval-< (x y)
+  (declare (type interval x y))
+  ;; X < Y only if X is bounded above, Y is bounded below, and they
+  ;; don't overlap.
+  (when (and (interval-bounded-p x 'above)
+	     (interval-bounded-p y 'below))
+    ;; Intervals are bounded in the appropriate way.  Make sure that don't overlap.
+    (let ((left (interval-high x))
+	  (right (interval-low y))) 
+      (cond ((> (bound-value left)
+		(bound-value right))
+	     ;; Definitely overlap so result is NIL
+	     nil)
+	    ((< (bound-value left)
+		(bound-value right))
+	     ;; Definitely don't touch, so result is T
+	     t)
+	    (t
+	     ;; Limits are equal.  Check for open or closed bounds.
+	     ;; Don't overlap if one or the other are open.
+	     (or (consp left) (consp right)))))))
+
+;;; INTERVAL-ABS
+;;;
+;;; Return an interval that is the absolute value of X.  Thus, if X =
+;;; [-1 10], the result is [0, 10].
+
+(defun interval-abs (x)
+  (declare (type interval x))
+  (case (interval-range-info x)
+    ('+
+     x)
+    ('-
+     (interval-neg x))
+    (t
+     (destructuring-bind (x- x+)
+	 (interval-split 0 x t t)
+       (interval-merge-pair (interval-neg x-) x+)))))
+
+;;; INTERVAL-SQR
+;;;
+;;; Compute the square of an interval.
+
+(defun interval-sqr (x)
+  (declare (type interval x))
+  (interval-func #'(lambda (x) (* x x))
+		 (interval-abs x)))
+) ; end progn
+
+
 
 ;;;; Numeric Derive-Type methods:
 
@@ -259,56 +717,78 @@
 ;;; This also contains derive-integer-type as a special case.
 ;;;
 #+propagate-float-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)))
 
-#+propagate-float-type
+;;; 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)
-  (cond ((union-type-p x)
-	 (let ((new-union '()))
-	   (dolist (type (union-type-types x))
-	     (setf new-union (cons (derive-real-numeric-or-union-type
-				    type y fun) new-union)))
-	   (make-union-type (derive-merged-union-types new-union))))
-	((union-type-p y)
-	 (let ((new-union '()))
-	   (dolist (type (union-type-types y))
-	     (setf new-union (cons (derive-real-numeric-or-union-type
-				    x type fun) new-union)))
-	   (make-union-type (derive-merged-union-types new-union))))
-	((and (numeric-type-p x) (numeric-type-p y))
-	 (derive-simple-real-type x y fun))
-	(t
-	 (numeric-contagion x y))))
+  (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)
+	      (make-union-type result)
+	      (first result)))))
 
-#+propagate-float-type
 (defun merge-types-aux (tlist)
   ;; 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.
   (let* ((cur (first tlist))
+	 (cur-intvrl (numeric-type->interval cur))
 	 (res (list cur)))
-    (multiple-value-bind (cur-lo cur-hi)
-	(extract-bounds cur)
-      (declare (ignore cur-lo))
-      (dolist (type (rest tlist)
-	       res)
-	(multiple-value-bind (type-lo type-hi)
-	    (extract-bounds type)
-	  (cond ((not (bound-< type-lo cur-hi))
-		 ;; Left limit of the current interval lies
-		 ;; within our interval, so merge these two
-		 ;; intervals into our interval.
-		 (setf (numeric-type-high cur)
-		       (nilify-bound (max-bound cur-hi type-hi))))
-		(t
-		 ;; Otherwise, we can't merge these two intervals
-		 (setf res (cons type res)))))))))
+    (dolist (this-interval (rest tlist) res)
+      (let ((this (numeric-type->interval this-interval)))
+	;; 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 (eq (numeric-type-class cur) 
+			(numeric-type-class this-interval))
+		    (or (interval-intersect-p cur-intvrl this)
+			(interval-adjacent-p cur-intvrl this)))
+	       (let ((result (interval-merge-pair cur-intvrl this)))
+		 (when result
+		   (setf (numeric-type-high cur)
+			 (interval-high result)))))
+	      (t
+	       (setf res (cons this-interval res))))))))
 
-#+propagate-float-type
 (defun merge-types (ilist &optional (result '()))
   ;; Compare the first element with the rest to merge
   ;; whatever we can into the first element.  The first
@@ -322,190 +802,71 @@
 	(t
 	 (cons (first ilist) result))))
 
-#+propagate-float-type
 (defun derive-merged-union-types (types)
-  (labels ((interval-< (a b)
-	     (multiple-value-bind (a-lo a-hi)
-		 (extract-bounds a)
-	       (declare (ignore a-hi))
-	       (multiple-value-bind (b-lo b-hi)
-		   (extract-bounds b)
-		 (declare (ignore b-hi))
-		 (bound-< a-lo b-lo)))))
-    (merge-types (sort types #'interval-<))))
+  (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-<))))
 
-#+propagate-float-type
 (defun derive-simple-real-type (x y fun)
-  (declare (type numeric-type x y) (type function fun))
-  (cond ((and (eq (numeric-type-class x) 'integer)
-	      (eq (numeric-type-class y) 'integer)
+  (declare (type function fun))
+  (cond ((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)
-	     (funcall fun x y)
-	   (make-numeric-type :class 'integer  :complexp :real
-			      :low low  :high high)))
-	((and (numeric-type-p x) (numeric-type-p y)
-	      (eq (numeric-type-class x) 'float)
-	      (eq (numeric-type-class y) 'float)
-	      (eq (numeric-type-complexp x) :real)
-	      (eq (numeric-type-complexp y) :real)
-	      (eq (numeric-type-format x) (numeric-type-format y)))
-	 ;; We have two floats of some kind.  We will handle float
-	 ;; contagion here instead of using the general
-	 ;; numeric-contagion which loses the bounds on the numbers,
-	 ;; if any.
-	 (multiple-value-bind (low high)
-	     (funcall fun x y)
-	   (make-numeric-type
-	    :class 'float
-	    :format (float-format-max (numeric-type-format x)
-				      (numeric-type-format y))
-	    :complexp :real
-	    :low low  :high high)))
+	 (cond ((and (eq (numeric-type-class x) 'integer)
+		     (eq (numeric-type-class y) 'integer))
+		(multiple-value-bind (low high)
+		    (funcall fun x y)
+		  (make-numeric-type :class 'integer  :complexp :real
+				     :low low  :high high)))
+	       ((and (eq (numeric-type-class x) 'float)
+		     (eq (numeric-type-class y) 'float))
+		;; We have two floats of some kind.  We will handle float
+		;; contagion here instead of using the general
+		;; numeric-contagion which loses the bounds on the numbers,
+		;; if any.
+		(multiple-value-bind (low high)
+		    (funcall fun x y)
+		  (make-numeric-type
+		   :class 'float
+		   :format (float-format-max (numeric-type-format x)
+					     (numeric-type-format y))
+		   :complexp :real
+		   :low low  :high high)))
+	       (t
+		;; Some kind of unhandled numeric type like rational.  Punt.
+		(numeric-contagion x y))))
 	(t
+	 ;; The arguments are not reals, so punt
 	 (numeric-contagion x y))))
+) ; end progn
 
 
-;;;; Helper methods for dealing with inclusive and exclusive bounds.
-
-;;; Return the value of a bound.  Ignore the issue if the bound is
-;;; inclusive or exclusive.  If no bound is given, return nil (which
-;;; is the bound value).
-
-(defun bound-value (bnd)
-  (if (consp bnd)
-      (car bnd)
-      bnd))
-
-;;; Take a numeric argument and extract the bounds.  If any bound is
-;;; not given (nil), return the appropriate infinity instead.
-
-(defun extract-bounds (arg)
-  (let ((lo (numeric-type-low arg))
-	(hi (numeric-type-high arg)))
-    ;; Replace nil values with the appropriate bound
-    (values (or lo 'neg-inf)
-	    (or hi 'pos-inf))))
-
-;;; Convert a bound from extract-bounds to be either the bound or nil.
-
-(defun nilify-bound (b)
-  (if (symbolp b)
-      nil
-      b))
-
-(defun set-bound (val exclusive)
-  (if (and (floatp val)
-	   (float-infinity-p val))
-      nil
-      (if exclusive
-	  `(,val)
-	  val)))
-
-(defun bound-< (x y)
-  (cond ((eq x 'pos-inf)
-	 nil)
-	((eq x 'neg-inf)
-	 (not (eq y 'neg-inf)))
-	(t
-	 ;; x is some number
-	 (if (symbolp y)
-	     (not (bound-< y x))
-	     ;; Both x and y are numbers
-	     (let ((xbnd (bound-value x))
-		   (ybnd (bound-value y)))
-	       (or (< xbnd ybnd)
-		   ;; If the bounds are equal, we need to check if the
-		   ;; bounds are exclusive.  The result is true if x is
-		   ;; an inclusive bound but y is not.
-		   (and (= xbnd ybnd)
-			(numberp x)
-			(consp y))))))))
-
-;;; Determine if a bound is less than zero
-
-(defun bound-minusp (b)
-  (bound-< b 0))
-
-;;; Determine if a bound is greater than zero
-
-(defun bound-plusp (b)
-  (not (bound-< b 0)))
-
-;;; Find the sign of a bound
-
-(defun bound-sign (x)
-  (cond ((eq x 'neg-inf)
-	 -1)
-	((eq x 'pos-inf)
-	 1)
-	(t
-	 (signum (bound-value x)))))
-
-;;; Compute the product of two bounds
-
-(defun bound-prod (x y)
-  (cond ((or (symbolp x) (symbolp y))
-	 ;; One of the numbers is infinity.  The result is also infinity.
-	 (if (minusp (* (bound-sign x) (bound-sign y)))
-	     'neg-inf
-	     'pos-inf))
-	(t
-	 ;; The limits are numbers.
-	 (let ((res (* (bound-value x) (bound-value y))))
-	   (set-bound res (or (consp x) (consp y)))))))
-  
-;;; Compute the quotient of two bounds
-
-(defun bound-quot (x y)
-  (cond ((symbolp x)
-	 ;; Infinity divided by anything will be infinity
-	 (bound-prod x y))
-	((symbolp y)
-	 ;; A number divided by infinity is always 0
-	 0)
-	(t
-	 ;; At this point we have the ratio of two numbers.  Watch out
-	 ;; for division by zero!
-	 (cond ((zerop (bound-value y))
-		(if (bound-minusp x)
-		    'neg-inf
-		    'pos-inf))
-	       (t
-		(let ((res (/ (bound-value x) (bound-value y))))
-		  (set-bound res (or (consp x) (consp y)))))))))
-
-;;; Compute the absolute value of a bound.  
-
-(defun bound-abs (x)
-  (if (symbolp x)
-      'pos-inf
-      (set-bound (abs (bound-value x)) (consp x))))
-
-;;; Given a list of float bounds, find the maximum.  If the maximum is
-;;; infinity, return nil instead.
-	     
-(defun max-bound (x y)
-  (if (bound-< x y)
-      y
-      x))
-
-(defun min-bound (x y)
-  (if (bound-< x y)
-      x
-      y))
-
-
-(defun max-bound-list (lst)
-  (nilify-bound (reduce #'max-bound lst)))
-
-(defun min-bound-list (lst)
-  (nilify-bound (reduce #'min-bound lst)))
-
-
-
 #-propagate-float-type
+(progn
 (defoptimizer (+ derive-type) ((x y))
   (derive-integer-type
    x y
@@ -517,29 +878,6 @@
 	 (values (frob (numeric-type-low x) (numeric-type-low y))
 		 (frob (numeric-type-high x) (numeric-type-high y)))))))
 
-#+propagate-float-type
-(defoptimizer (+ derive-type) ((x y))
-  (derive-real-type
-   x y
-   #'(lambda (x y)
-       (labels ((frob (x y)
-		  (if (and x y)
-		      (set-bound (+ (bound-value x) (bound-value y))
-				 (or (consp x) (consp y)))
-		      nil)))
-	 #|
-	 (debug:backtrace)
-	 (format t "~%+-derive:  ~s ~s~%" x y)
-	 (format t "to ~s ~s~%"
-		 (frob (numeric-type-low x) (numeric-type-low y))
-		 (frob (numeric-type-high x) (numeric-type-high y)))
-	 |#
-	 
-	 (values (frob (numeric-type-low x) (numeric-type-low y))
-		 (frob (numeric-type-high x) (numeric-type-high y)))))))
-
-
-#-propagate-float-type
 (defoptimizer (- derive-type) ((x y))
   (derive-integer-type
    x y
@@ -551,20 +889,7 @@
 	 (values (frob (numeric-type-low x) (numeric-type-high y))
 		 (frob (numeric-type-high x) (numeric-type-low y)))))))
 
-#+propagate-float-type
-(defoptimizer (- derive-type) ((x y))
-  (derive-real-type
-   x y
-   #'(lambda (x y)
-       (labels ((frob (x y)
-		  (if (and x y)
-		      (set-bound (- (bound-value x) (bound-value y))
-				 (or (consp x) (consp y)))
-		      nil)))
-	 (values (frob (numeric-type-low x) (numeric-type-high y))
-		 (frob (numeric-type-high x) (numeric-type-low y)))))))
 
-#-propagate-float-type
 (defoptimizer (* derive-type) ((x y))
   (derive-integer-type
    x y
@@ -587,48 +912,43 @@
 			    (* x-high y-high)
 			    nil))))))))
 
+(defoptimizer (/ derive-type) ((x y))
+  (numeric-contagion (continuation-type x) (continuation-type y)))
+
+) ; end progn
+
 #+propagate-float-type
+(progn
+(defoptimizer (+ derive-type) ((x y))
+  (derive-real-type
+   x y
+   #'(lambda (x y)
+       (declare (type numeric-type x y))
+       (let ((result (interval-add (numeric-type->interval x)
+				   (numeric-type->interval y))))
+	 (values (interval-low result) (interval-high result))))))
+
+(defoptimizer (- derive-type) ((x y))
+  (derive-real-type
+   x y
+   #'(lambda (x y)
+       (declare (type numeric-type x y))
+       (let ((result (interval-sub (numeric-type->interval x)
+				   (numeric-type->interval y))))
+	 (values (interval-low result) (interval-high result))))))
+
 (defoptimizer (* derive-type) ((x y))
   (let ((same-arg (same-leaf-ref-p x y)))
     (derive-real-type
      x y
      #'(lambda (x y)
-	 (multiple-value-bind (x-low x-high)
-	     (extract-bounds x)
-	   (cond (same-arg
-		  (let ((new-limits (list (bound-prod x-low x-low)
-					  (bound-prod x-high x-high))))
-		    ;; There are two cases to handle: 0 is in
-		    ;; the range and 0 is not.
-		    (cond ((and (bound-minusp x-low)
-				(bound-plusp x-high))
-			   ;; The low limit is 0 and the high
-			   ;; is the max of the square of the
-			   ;; bounds.  
-			   (values 0
-				   (max-bound-list new-limits)))
-			  (t
-			   ;; Since zero is not within the
-			   ;; range, the answer is obvious
-			   (values (min-bound-list new-limits)
-				   (max-bound-list new-limits))))))
-			  (t
-			   (multiple-value-bind (y-low y-high)
-			       (extract-bounds y)
-			     (let ((new-limits (list (bound-prod x-low y-low)
-						     (bound-prod x-low y-high)
-						     (bound-prod x-high y-low)
-						     (bound-prod x-high y-high))))
-			       (values (min-bound-list new-limits)
-				       (max-bound-list new-limits)))))))))))
+	 (let ((result
+		(if same-arg
+		    (interval-sqr (numeric-type->interval x))
+		    (interval-mul (numeric-type->interval x)
+				  (numeric-type->interval y)))))
+	   (values (interval-low result) (interval-high result)))))))
 
-
-
-#-propagate-float-type
-(defoptimizer (/ derive-type) ((x y))
-  (numeric-contagion (continuation-type x) (continuation-type y)))
-
-#+propagate-float-type
 (defoptimizer (/ derive-type) ((top bot))
   ;; We only handle the case where both of the arguments are
   ;; floats. Otherwise, the general numeric contagion holds.
@@ -644,22 +964,11 @@
 	(derive-real-type
 	 top bot
 	 #'(lambda (x y)
-	     (multiple-value-bind (y-low y-high)
-		 (extract-bounds y)
-	       (cond ((and (bound-minusp y-low)
-			   (bound-plusp y-high))
-		      ;; If 0 is within the bounds of y, the result is
-		      ;; clear: any float is possible for the quotient.
-		      (values nil nil))
-		     (t
-		      (multiple-value-bind (x-low x-high)
-			  (extract-bounds x)
-			(let ((new-limits (list (bound-quot x-low y-low)
-						(bound-quot x-low y-high)
-						(bound-quot x-high y-low)
-						(bound-quot x-high y-high))))
-			  (values (min-bound-list new-limits)
-				  (max-bound-list new-limits))))))))))))
+	     (let ((result (interval-div (numeric-type->interval x)
+					 (numeric-type->interval y))))
+	       (values (interval-low result) (interval-high result))))))))
+
+) ;end progn
 
 
 (defoptimizer (ash derive-type) ((n shift))
@@ -760,22 +1069,12 @@
 	    ((eq (numeric-type-complexp type) :real)
 	     ;; The absolute value of a real number is a non-negative
 	     ;; real of the same type.
-	     (let ((lo (numeric-type-low type))
-		   (hi (numeric-type-high 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 (cond ((and hi (minusp (bound-value hi)))
-					      (bound-abs hi))
-					     (lo
-					      (set-bound (max 0 (bound-value lo))
-							 (consp lo)))
-					     (t
-					      0))
-				  :high (if (and hi lo)
-					    (max-bound-list (list (bound-abs hi)
-								  (bound-abs lo)))
-					    nil))))))))
+				  :low (interval-low abs-bnd)
+				  :high (interval-high abs-bnd))))))))
 
 
 #-propagate-float-type
@@ -862,12 +1161,8 @@
 			:class 'integer
 			:low 1
 			:high 1)))
-	  (setf number-low (if (consp number-low)
-			       (car number-low)
-			       number-low))
-	  (setf number-high (if (consp number-high)
-				(car number-high)
-				number-high))
+	  (setf number-low (if (consp number-low) (car number-low) number-low))
+	  (setf number-high (if (consp number-high) (car number-high) number-high))
 	  (specifier-type `,(integer-truncate-derive-type
 			     number-low number-high 1 1 divisor)))
 	*universal-type*)))
@@ -881,7 +1176,7 @@
 ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
 ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
 ;;; - The abs of the maximal value if there is one, or nil if it is unbounded.
-;;; 
+;;;
 (defun numeric-range-info (low high)
   (cond ((and low (not (minusp low)))
 	 (values '+ low high))
@@ -956,7 +1251,7 @@
 	     ;; The number we are dividing is unbounded, so we can't tell
 	     ;; anything about the result.
 	     'integer)))))
-	  
+
 (defun integer-rem-derive-type
        (number-low number-high divisor-low divisor-high)
   (if (and divisor-low divisor-high)
@@ -988,97 +1283,101 @@
 
 #+propagate-float-type
 (progn
+(defun truncate-carefully (x y)
+  (handler-case (truncate x y)
+    (arithmetic-error ()
+      '*)))
+
+(defun negative-truncate-carefully (x y)
+  (handler-case (- (truncate x y))
+    (arithmetic-error ()
+      '*)))
+
 (defun integer-truncate-derive-type
-    (number-low number-high divisor-low divisor-high divisor-type)
+    (number-low number-high divisor-low divisor-high
+		divisor-type)
   ;; The result cannot be larger in magnitude than the number, but the sign
   ;; might change.  If we can determine the sign of either the number or
   ;; the divisor, we can eliminate some of the cases.
-  (macrolet ((maybe* (form)
-	       ;; return result of form or * if overflow occurs
-	       `(handler-case ,form
-		  (arithmetic-error () '*))))
+  (multiple-value-bind
+      (number-sign number-min number-max)
+      (numeric-range-info number-low number-high)
     (multiple-value-bind
-	(number-sign number-min number-max)
-	(numeric-range-info number-low number-high)
-      (multiple-value-bind
-	  (divisor-sign divisor-min divisor-max)
-	  (numeric-range-info divisor-low divisor-high)
-	(when (and divisor-max (zerop divisor-max))
-	  ;; 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 aren't going to divide by zero.  Set
-	  ;; divisor min to be the smallest positive number of the
-	  ;; appropriate type.  (Does this really make sense for floats?
-	  ;; Let's go with it for now.)
-	  (setf divisor-min
-		(cond ((csubtypep divisor-type (specifier-type 'integer))
-		       1)
-		      ((csubtypep divisor-type (specifier-type 'double-float))
-		       least-positive-normalized-double-float)
-		      ((csubtypep divisor-type (specifier-type 'real))
-		       least-positive-normalized-single-float)
-		      (t
-		       (cerror "Return INTEGER as result of truncate"
-			       "This should not have happened!")
-		       (return-from integer-truncate-derive-type t)))))
-	(cond ((and number-sign divisor-sign)
-	       ;; We know the sign of both.
-	       (if (eq number-sign divisor-sign)
-		   ;; Same sign, so the result will be positive.
-		   `(integer
-		     ,(if divisor-max
-			  (maybe* (truncate number-min divisor-max))
-			  0)
-		     ,(if number-max
-			  (maybe* (truncate number-max divisor-min))
-			  '*))
-		   ;; Different signs, the result will be negative.
-		   `(integer
-		     ,(if number-max
-			  (maybe* (- (truncate number-max divisor-min)))
-			  '*)
-		     ,(if divisor-max
-			  (maybe* (- (truncate number-min divisor-max)))
-			  0))))
-	      ((eq divisor-sign '+)
-	       ;; The divisor is positive.  Therefore, the number will just
-	       ;; become closer to zero.
-	       `(integer
-		 ,(if number-low
-		      (maybe* (truncate number-low divisor-min))
-		      '*)
-		 ,(if number-high
-		      (maybe* (truncate number-high divisor-min))
-		      '*)))
-	      ((eq divisor-sign '-)
-	       ;; The divisor is negative.  Therefore, the absolute value of
-	       ;; the number will become closer to zero, but the sign will also
-	       ;; change.
-	       `(integer
-		 ,(if number-high
-		      (maybe* (- (truncate number-high divisor-min)))
-		      '*)
-		 ,(if number-low
-		      (maybe* (- (truncate number-low divisor-min)))
-		      '*)))
-	      ;; The divisor could be either positive or negative.
-	      (number-max
-	       ;; The number we are dividing has a bound.  Divide that by the
-	       ;; smallest posible divisor.
-	       (let ((bound (maybe* (truncate number-max divisor-min))))
-		 (if (numberp bound)
-		     `(integer ,(- bound) ,bound)
-		     `integer)))
-	      (t
-	       ;; The number we are dividing is unbounded, so we can't tell
-	       ;; anything about the result.
-	       'integer))))))
+	(divisor-sign divisor-min divisor-max)
+	(numeric-range-info divisor-low divisor-high)
+      (when (and divisor-max (zerop divisor-max))
+	;; 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 aren't going to divide by zero.  Set
+	;; divisor min to be the smallest positive number of the
+	;; appropriate type.  (Does this really make sense for floats?
+	;; Let's go with it for now.)
+	(setf divisor-min
+	      (cond ((csubtypep divisor-type (specifier-type 'integer))
+		     1)
+		    ((csubtypep divisor-type (specifier-type 'double-float))
+		     least-positive-normalized-double-float)
+		    ((csubtypep divisor-type (specifier-type 'real))
+		     least-positive-normalized-single-float)
+		    (t
+		     (cerror "Return INTEGER as result of truncate"
+			     "This should not have happened!")
+		     (return-from integer-truncate-derive-type t)))))
+      (cond ((and number-sign divisor-sign)
+		 ;; We know the sign of both.
+		 (if (eq number-sign divisor-sign)
+		     ;; Same sign, so the result will be positive.
+		     `(integer ,(if divisor-max
+				    (truncate-carefully number-min divisor-max)
+				    0)
+		       ,(if number-max
+			    (truncate-carefully number-max divisor-min)
+			    '*))
+		     ;; Different signs, the result will be negative.
+		     `(integer ,(if number-max
+				    (negative-truncate-carefully number-max divisor-min)
+				    '*)
+		       ,(if divisor-max
+			    (negative-truncate-carefully number-min divisor-max)
+			    0))))
+		((eq divisor-sign '+)
+		 ;; The divisor is positive.  Therefore, the number will just
+		 ;; become closer to zero.
+		 `(integer ,(if number-low
+				(truncate-carefully number-low divisor-min)
+				'*)
+		   ,(if number-high
+			(truncate-carefully number-high divisor-min)
+			'*)))
+		((eq divisor-sign '-)
+		 ;; The divisor is negative.  Therefore, the absolute value of
+		 ;; the number will become closer to zero, but the sign will also
+		 ;; change.
+		 `(integer ,(if number-high
+				(negative-truncate-carefully number-high divisor-min)
+				'*)
+		   ,(if number-low
+			(negative-truncate-carefully number-low divisor-min)
+			'*)))
+		;; The divisor could be either positive or negative.
+		(number-max
+		 ;; The number we are dividing has a bound.  Divide that by the
+		 ;; smallest posible divisor.
+		 (let ((bound (truncate-carefully number-max divisor-min)))
+		   (if (numberp bound)
+		       `(integer ,(- bound) ,bound)
+		       `integer)))
+		(t
+		 ;; The number we are dividing is unbounded, so we can't tell
+		 ;; anything about the result.
+		 'integer)))))
 
 ;;; This probably needs a lot of reworking to make sure everything is
 ;;; covered.
 (defun real-rem-derive-type
-    (number-low number-high divisor-low divisor-high number-type divisor-type)
+    (number-low number-high divisor-low divisor-high
+		number-type divisor-type)
   ;; First figure out what the type of the result should be.
   (let* ((result-type
 	  (cond ((csubtypep number-type (specifier-type 'integer))
@@ -1945,24 +2244,17 @@
 (defun ir1-transform-< (x y first second inverse)
   (if (same-leaf-ref-p x y)
       'nil
-      (let* ((x-type (numeric-type-or-lose x))
-	     (y-type (numeric-type-or-lose y)))
-	#+nil
-	(format t "ir1-trans-<:~%  ~s~%  ~s~%" x-type y-type)
-	(multiple-value-bind (x-lo x-hi)
-	    (extract-bounds x-type)
-	  (multiple-value-bind (y-lo y-hi)
-	      (extract-bounds y-type)
-	    (cond ((bound-< x-hi y-lo)
-		   't)
-		  ((bound-< y-hi x-lo)
-		   'nil)
-		  ((and (constant-continuation-p first)
-			(not (constant-continuation-p second)))
-		   `(,inverse y x))
-		  (t
-		   (give-up))))))))
-	      
+      (let ((xi (numeric-type->interval (numeric-type-or-lose x)))
+	    (yi (numeric-type->interval (numeric-type-or-lose y))))
+	(cond ((interval-< xi yi)
+	       t)
+	      ((interval-< yi xi)
+	       nil)
+	      ((and (constant-continuation-p first)
+		    (not (constant-continuation-p second)))
+	       `(,inverse y x))
+	      (t
+	       (give-up))))))
 
 (deftransform < ((x y) (integer integer) * :when :both)
   (ir1-transform-< x y x y '>))
@@ -2218,6 +2510,3 @@
        (declare (ignore tee))
        (funcall control *standard-output* ,@arg-names)
        nil)))
-
-
-