X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=6f6e61081a9a79084a162c0374012bc5e55ce55f;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=1887261b1d15bbf2274fc0b3b19b8d0faa76d082;hpb=58ff25d134554f86b15d1978ae21861ccbe70f3d;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 1887261..6f6e610 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -22,14 +22,8 @@
 
 ;;; ### Remaining incorrectnesses:
 ;;;
-;;; TYPE-UNION (and the OR type) doesn't properly canonicalize an
-;;; exhaustive partition or coalesce contiguous ranges of numeric
-;;; types.
-;;;
 ;;; There are all sorts of nasty problems with open bounds on FLOAT
 ;;; types (and probably FLOAT types in general.)
-;;;
-;;; RATIO and BIGNUM are not recognized as numeric types.
 
 ;;; FIXME: This really should go away. Alas, it doesn't seem to be so
 ;;; simple to make it go away.. (See bug 123 in BUGS file.)
@@ -77,15 +71,16 @@
       (values
        ;; FIXME: This old CMU CL code probably deserves a comment
        ;; explaining to us mere mortals how it works...
-       (and (sb!xc:typep type2 'sb!xc:class)
+       (and (sb!xc:typep type2 'classoid)
 	    (dolist (x info nil)
 	      (when (or (not (cdr x))
 			(csubtypep type1 (specifier-type (cdr x))))
 		(return
 		 (or (eq type2 (car x))
-		     (let ((inherits (layout-inherits (class-layout (car x)))))
+		     (let ((inherits (layout-inherits
+				      (classoid-layout (car x)))))
 		       (dotimes (i (length inherits) nil)
-			 (when (eq type2 (layout-class (svref inherits i)))
+			 (when (eq type2 (layout-classoid (svref inherits i)))
 			   (return t)))))))))
        t)))
 
@@ -110,7 +105,7 @@
 			      (destructuring-bind
 				  (super &optional guard)
 				  spec
-				(cons (sb!xc:find-class super) guard)))
+				(cons (find-classoid super) guard)))
 			    ',specs)))
 	 (setf (type-class-complex-subtypep-arg1 ,type-class)
 	       (lambda (type1 type2)
@@ -230,43 +225,35 @@
                     (csubtypep a1 a2)
                   (unless res (return (values res sure-p))))
              finally (return (values t t)))))
-   (macrolet ((3and (x y)
-                `(multiple-value-bind (val1 win1) ,x
-                   (if (and (not val1) win1)
-                       (values nil t)
-                       (multiple-value-bind (val2 win2) ,y
-                         (if (and val1 val2)
-                             (values t t)
-                             (values nil (and win2 (not val2)))))))))
-     (3and (values-subtypep (fun-type-returns type1)
-                            (fun-type-returns type2))
-           (cond ((fun-type-wild-args type2) (values t t))
-                 ((fun-type-wild-args type1)
-                  (cond ((fun-type-keyp type2) (values nil nil))
-                        ((not (fun-type-rest type2)) (values nil t))
-                        ((not (null (fun-type-required type2))) (values nil t))
-                        (t (3and (type= *universal-type* (fun-type-rest type2))
-                                 (every/type #'type= *universal-type*
-                                             (fun-type-optional type2))))))
-                 ((not (and (fun-type-simple-p type1)
-                            (fun-type-simple-p type2)))
-                  (values nil nil))
-                 (t (multiple-value-bind (min1 max1) (fun-type-nargs type1)
-                      (multiple-value-bind (min2 max2) (fun-type-nargs type2)
-                        (cond ((or (> max1 max2) (< min1 min2))
-                               (values nil t))
-                              ((and (= min1 min2) (= max1 max2))
-                               (3and (every-csubtypep (fun-type-required type1)
-                                                      (fun-type-required type2))
-                                     (every-csubtypep (fun-type-optional type1)
-                                                      (fun-type-optional type2))))
-                              (t (every-csubtypep
-                                  (concatenate 'list
-                                               (fun-type-required type1)
-                                               (fun-type-optional type1))
-                                  (concatenate 'list
-                                               (fun-type-required type2)
-                                               (fun-type-optional type2)))))))))))))
+   (and/type (values-subtypep (fun-type-returns type1)
+                              (fun-type-returns type2))
+             (cond ((fun-type-wild-args type2) (values t t))
+                   ((fun-type-wild-args type1)
+                    (cond ((fun-type-keyp type2) (values nil nil))
+                          ((not (fun-type-rest type2)) (values nil t))
+                          ((not (null (fun-type-required type2))) (values nil t))
+                          (t (and/type (type= *universal-type* (fun-type-rest type2))
+                                       (every/type #'type= *universal-type*
+                                                   (fun-type-optional type2))))))
+                   ((not (and (fun-type-simple-p type1)
+                              (fun-type-simple-p type2)))
+                    (values nil nil))
+                   (t (multiple-value-bind (min1 max1) (fun-type-nargs type1)
+                        (multiple-value-bind (min2 max2) (fun-type-nargs type2)
+                          (cond ((or (> max1 max2) (< min1 min2))
+                                 (values nil t))
+                                ((and (= min1 min2) (= max1 max2))
+                                 (and/type (every-csubtypep (fun-type-required type1)
+                                                            (fun-type-required type2))
+                                           (every-csubtypep (fun-type-optional type1)
+                                                            (fun-type-optional type2))))
+                                (t (every-csubtypep
+                                    (concatenate 'list
+                                                 (fun-type-required type1)
+                                                 (fun-type-optional type1))
+                                    (concatenate 'list
+                                                 (fun-type-required type2)
+                                                 (fun-type-optional type2))))))))))))
 
 (!define-superclasses function ((function)) !cold-init-forms)
 
@@ -278,6 +265,18 @@
   (declare (ignore type1 type2))
   (specifier-type 'function))
 
+;;; The union or intersection of a subclass of FUNCTION with a
+;;; FUNCTION type is somewhat complicated.
+(!define-type-method (function :complex-intersection2) (type1 type2)
+  (cond
+    ((type= type1 (specifier-type 'function)) type2)
+    ((csubtypep type1 (specifier-type 'function)) nil)
+    (t :call-other-method)))
+(!define-type-method (function :complex-union2) (type1 type2)
+  (cond
+    ((type= type1 (specifier-type 'function)) type1)
+    (t nil)))
+
 ;;; ### Not very real, but good enough for redefining transforms
 ;;; according to type:
 (!define-type-method (function :simple-=) (type1 type2)
@@ -294,37 +293,6 @@
 (!def-type-translator constant-arg (type)
   (make-constant-type :type (specifier-type type)))
 
-;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE
-;;; structure, fill in the slots in the structure accordingly. This is
-;;; used for both FUNCTION and VALUES types.
-(declaim (ftype (function (list args-type) (values)) parse-args-types))
-(defun parse-args-types (lambda-list result)
-  (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux)
-      (parse-lambda-list-like-thing lambda-list)
-    (declare (ignore aux)) ; since we require AUXP=NIL
-    (when auxp
-      (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list))
-    (setf (args-type-required result)
-          (mapcar #'single-value-specifier-type required))
-    (setf (args-type-optional result)
-          (mapcar #'single-value-specifier-type optional))
-    (setf (args-type-rest result)
-          (if restp (single-value-specifier-type rest) nil))
-    (setf (args-type-keyp result) keyp)
-    (collect ((key-info))
-      (dolist (key keys)
-	(unless (proper-list-of-length-p key 2)
-	  (error "Keyword type description is not a two-list: ~S." key))
-	(let ((kwd (first key)))
-	  (when (find kwd (key-info) :key #'key-info-name)
-	    (error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
-		   kwd lambda-list))
-	  (key-info (make-key-info :name kwd
-				   :type (single-value-specifier-type (second key))))))
-      (setf (args-type-keywords result) (key-info)))
-    (setf (args-type-allowp result) allowp)
-    (values)))
-
 ;;; Return the lambda-list-like type specification corresponding
 ;;; to an ARGS-TYPE.
 (declaim (ftype (function (args-type) list) unparse-args-types))
@@ -355,16 +323,10 @@
     (result)))
 
 (!def-type-translator function (&optional (args '*) (result '*))
-  (let ((res (make-fun-type :returns (values-specifier-type result))))
-    (if (eq args '*)
-	(setf (fun-type-wild-args res) t)
-	(parse-args-types args res))
-    res))
+  (make-fun-type :args args :returns (values-specifier-type result)))
 
 (!def-type-translator values (&rest values)
-  (let ((res (%make-values-type)))
-    (parse-args-types values res)
-    res))
+  (make-values-type :args values))
 
 ;;;; VALUES types interfaces
 ;;;;
@@ -394,7 +356,7 @@
 ;;; type, return NIL, NIL.
 (defun fun-type-nargs (type)
   (declare (type ctype type))
-  (if (fun-type-p type)
+  (if (and (fun-type-p type) (not (fun-type-wild-args type)))
       (let ((fixed (length (args-type-required type))))
 	(if (or (args-type-rest type)
 		(args-type-keyp type)
@@ -729,14 +691,14 @@
   (flet ((1way (x y)
 	   (!invoke-type-method :simple-intersection2 :complex-intersection2
 				x y
-				:default :no-type-method-found)))
+				:default :call-other-method)))
     (declare (inline 1way))
     (let ((xy (1way type1 type2)))
-      (or (and (not (eql xy :no-type-method-found)) xy)
+      (or (and (not (eql xy :call-other-method)) xy)
 	  (let ((yx (1way type2 type1)))
-	    (or (and (not (eql yx :no-type-method-found)) yx)
-		(cond ((and (eql xy :no-type-method-found)
-			    (eql yx :no-type-method-found))
+	    (or (and (not (eql yx :call-other-method)) yx)
+		(cond ((and (eql xy :call-other-method)
+			    (eql yx :call-other-method))
 		       *empty-type*)
 		      (t
 		       (aver (and (not xy) (not yx))) ; else handled above
@@ -894,7 +856,7 @@
 ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE
 ;;; object whose components are the types in TYPES, or skip to special
 ;;; cases when TYPES is short.
-(defun make-compound-type-or-something (constructor types enumerable identity)
+(defun make-probably-compound-type (constructor types enumerable identity)
   (declare (type function constructor))
   (declare (type (vector ctype) types))
   (declare (type ctype identity))
@@ -908,7 +870,7 @@
 		;; brain-dead, so that would generate a full call to
 		;; SPECIFIER-TYPE at runtime, so we get into bootstrap
 		;; problems in cold init because 'LIST is a compound
-		;; type, so we need to MAKE-COMPOUND-TYPE-OR-SOMETHING
+		;; type, so we need to MAKE-PROBABLY-COMPOUND-TYPE
 		;; before we know what 'LIST is. Once the COERCE
 		;; optimizer is less brain-dead, we can make this
 		;; (COERCE TYPES 'LIST) again.
@@ -956,11 +918,11 @@
 	       :specifier `(and ,@(map 'list
 				       #'type-specifier
 				       simplified-types)))))
-	(make-compound-type-or-something #'%make-intersection-type
-					 simplified-types
-					 (some #'type-enumerable
-					       simplified-types)
-					 *universal-type*))))
+	(make-probably-compound-type #'%make-intersection-type
+				     simplified-types
+				     (some #'type-enumerable
+					   simplified-types)
+				     *universal-type*))))
 
 (defun type-union (&rest input-types)
   (%type-union input-types))
@@ -971,10 +933,10 @@
   (let ((simplified-types (simplified-compound-types input-types
 						     #'union-type-p
 						     #'type-union2)))
-    (make-compound-type-or-something #'make-union-type
-				     simplified-types
-				     (every #'type-enumerable simplified-types)
-				     *empty-type*)))
+    (make-probably-compound-type #'make-union-type
+				 simplified-types
+				 (every #'type-enumerable simplified-types)
+				 *empty-type*)))
 
 ;;;; built-in types
 
@@ -1011,6 +973,23 @@
   ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type.
   (values (eq type1 type2) t))
 
+(!define-type-method (named :complex-=) (type1 type2)
+  (cond
+    ((and (eq type2 *empty-type*)
+	  (intersection-type-p type1)
+	  ;; not allowed to be unsure on these... FIXME: keep the list
+	  ;; of CL types that are intersection types once and only
+	  ;; once.
+	  (not (or (type= type1 (specifier-type 'ratio))
+		   (type= type1 (specifier-type 'keyword)))))
+     ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION
+     ;; STREAM) can get here.  In general, we can't really tell
+     ;; whether these are equal to NIL or not, so
+     (values nil nil))
+    ((type-might-contain-other-types-p type1)
+     (invoke-complex-=-other-method type1 type2))
+    (t (values nil t))))
+
 (!define-type-method (named :simple-subtypep) (type1 type2)
   (aver (not (eq type1 *wild-type*))) ; * isn't really a type.
   (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
@@ -1053,7 +1032,9 @@
   (aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (cond ((eq type2 *universal-type*)
 	 (values t t))
-	((hairy-type-p type1)
+	((type-might-contain-other-types-p type1)
+	 ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in
+	 ;; disguise.  So we'd better delegate.
 	 (invoke-complex-subtypep-arg1-method type1 type2))
 	(t
 	 ;; FIXME: This seems to rely on there only being 2 or 3
@@ -1145,7 +1126,8 @@
 	 (intersection2 (type-intersection2 type1
 					    complement-type2)))
     (if intersection2
-	(values (eq intersection2 *empty-type*) t)
+	;; FIXME: if uncertain, maybe try arg1?
+	(type= intersection2 *empty-type*)
 	(invoke-complex-subtypep-arg1-method type1 type2))))
 
 (!define-type-method (negation :complex-subtypep-arg1) (type1 type2)
@@ -1233,9 +1215,9 @@
 
 (!define-type-method (negation :complex-=) (type1 type2)
   ;; (NOT FOO) isn't equivalent to anything that's not a negation
-  ;; type, except possibly a hairy type.
+  ;; type, except possibly a type that might contain it in disguise.
   (declare (ignore type2))
-  (if (hairy-type-p type1)
+  (if (type-might-contain-other-types-p type1)
       (values nil nil)
       (values nil t)))
 
@@ -1307,24 +1289,24 @@
 	   (modified-numeric-type
 	    not-type
 	    :low (let ((h (numeric-type-high not-type)))
-		   (if (consp h) h (list h)))
+		   (if (consp h) (car h) (list h)))
 	    :high nil))
 	  ((null (numeric-type-high not-type))
 	   (modified-numeric-type
 	    not-type
 	    :low nil
 	    :high (let ((l (numeric-type-low not-type)))
-		    (if (consp l) l (list l)))))
+		    (if (consp l) (car l) (list l)))))
 	  (t (type-union
 	      (modified-numeric-type
 	       not-type
 	       :low nil
 	       :high (let ((l (numeric-type-low not-type)))
-		       (if (consp l) l (list l))))
+		       (if (consp l) (car l) (list l))))
 	      (modified-numeric-type
 	       not-type
 	       :low (let ((h (numeric-type-high not-type)))
-		      (if (consp h) h (list h)))
+		      (if (consp h) (car h) (list h)))
 	       :high nil))))))
       ((intersection-type-p not-type)
        (apply #'type-union
@@ -1336,6 +1318,69 @@
 	      (mapcar #'(lambda (x)
 			  (specifier-type `(not ,(type-specifier x))))
 		      (union-type-types not-type))))
+      ((member-type-p not-type)
+       (let ((members (member-type-members not-type)))
+	 (if (some #'floatp members)
+	     (let (floats)
+	       (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0)
+			       #!+long-float (0.0l0 . -0.0l0)))
+		 (when (member (car pair) members)
+		   (aver (not (member (cdr pair) members)))
+		   (push (cdr pair) floats)
+		   (setf members (remove (car pair) members)))
+		 (when (member (cdr pair) members)
+		   (aver (not (member (car pair) members)))
+		   (push (car pair) floats)
+		   (setf members (remove (cdr pair) members))))
+	       (apply #'type-intersection
+		      (if (null members)
+			  *universal-type*
+			  (make-negation-type
+			   :type (make-member-type :members members)))
+		      (mapcar
+		       (lambda (x)
+			 (let ((type (ctype-of x)))
+			   (type-union
+			    (make-negation-type
+			     :type (modified-numeric-type type
+							  :low nil :high nil))
+			    (modified-numeric-type type
+						   :low nil :high (list x))
+			    (make-member-type :members (list x))
+			    (modified-numeric-type type
+						   :low (list x) :high nil))))
+		       floats)))
+	     (make-negation-type :type not-type))))
+      ((and (cons-type-p not-type)
+	    (eq (cons-type-car-type not-type) *universal-type*)
+	    (eq (cons-type-cdr-type not-type) *universal-type*))
+       (make-negation-type :type not-type))
+      ((cons-type-p not-type)
+       (type-union
+	(make-negation-type :type (specifier-type 'cons))
+	(cond
+	  ((and (not (eq (cons-type-car-type not-type) *universal-type*))
+		(not (eq (cons-type-cdr-type not-type) *universal-type*)))
+	   (type-union
+	    (make-cons-type
+	     (specifier-type `(not ,(type-specifier
+				     (cons-type-car-type not-type))))
+	     *universal-type*)
+	    (make-cons-type
+	     *universal-type*
+	     (specifier-type `(not ,(type-specifier
+				     (cons-type-cdr-type not-type)))))))
+	  ((not (eq (cons-type-car-type not-type) *universal-type*))
+	   (make-cons-type
+	    (specifier-type `(not ,(type-specifier
+				    (cons-type-car-type not-type))))
+	    *universal-type*))
+	  ((not (eq (cons-type-cdr-type not-type) *universal-type*))
+	   (make-cons-type
+	    *universal-type*
+	    (specifier-type `(not ,(type-specifier
+				    (cons-type-cdr-type not-type))))))
+	  (t (bug "Weird CONS type ~S" not-type)))))
       (t (make-negation-type :type not-type)))))
 
 ;;;; numeric types
@@ -1347,8 +1392,8 @@
    (and (eq (numeric-type-class type1) (numeric-type-class type2))
 	(eq (numeric-type-format type1) (numeric-type-format type2))
 	(eq (numeric-type-complexp type1) (numeric-type-complexp type2))
-	(equal (numeric-type-low type1) (numeric-type-low type2))
-	(equal (numeric-type-high type1) (numeric-type-high type2)))
+	(equalp (numeric-type-low type1) (numeric-type-low type2))
+	(equalp (numeric-type-high type1) (numeric-type-high type2)))
    t))
 
 (!define-type-method (number :unparse) (type)
@@ -1408,7 +1453,6 @@
 ;;;
 ;;; This is for comparing bounds of the same kind, e.g. upper and
 ;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds.
-#!-negative-zero-is-not-zero
 (defmacro numeric-bound-test (x y closed open)
   `(cond ((not ,y) t)
 	 ((not ,x) nil)
@@ -1421,32 +1465,12 @@
 	      (,open ,x (car ,y))
 	      (,closed ,x ,y)))))
 
-#!+negative-zero-is-not-zero
-(defmacro numeric-bound-test-zero (op x y)
-  `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y))
-       (,op (float-sign ,x) (float-sign ,y))
-       (,op ,x ,y)))
-
-#!+negative-zero-is-not-zero
-(defmacro numeric-bound-test (x y closed open)
-  `(cond ((not ,y) t)
-	 ((not ,x) nil)
-	 ((consp ,x)
-	  (if (consp ,y)
-	      (numeric-bound-test-zero ,closed (car ,x) (car ,y))
-	      (numeric-bound-test-zero ,closed (car ,x) ,y)))
-	 (t
-	  (if (consp ,y)
-	      (numeric-bound-test-zero ,open ,x (car ,y))
-	      (numeric-bound-test-zero ,closed ,x ,y)))))
-
 ;;; This is used to compare upper and lower bounds. This is different
 ;;; from the same-bound case:
 ;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we
 ;;;    return true if *either* arg is NIL.
 ;;; -- an open inner bound is "greater" and also squeezes the interval,
 ;;;    causing us to use the OPEN test for those cases as well.
-#!-negative-zero-is-not-zero
 (defmacro numeric-bound-test* (x y closed open)
   `(cond ((not ,y) t)
 	 ((not ,x) t)
@@ -1459,19 +1483,6 @@
 	      (,open ,x (car ,y))
 	      (,closed ,x ,y)))))
 
-#!+negative-zero-is-not-zero
-(defmacro numeric-bound-test* (x y closed open)
-  `(cond ((not ,y) t)
-	 ((not ,x) t)
-	 ((consp ,x)
-	  (if (consp ,y)
-	      (numeric-bound-test-zero ,open (car ,x) (car ,y))
-	      (numeric-bound-test-zero ,open (car ,x) ,y)))
-	 (t
-	  (if (consp ,y)
-	      (numeric-bound-test-zero ,open ,x (car ,y))
-	      (numeric-bound-test-zero ,closed ,x ,y)))))
-
 ;;; Return whichever of the numeric bounds X and Y is "maximal"
 ;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >).
 ;;; This is only meaningful for maximizing like bounds, i.e. upper and
@@ -1505,11 +1516,13 @@
 		    (null complexp2)))
 	   (values nil t))
 	  ;; If the classes are specified and different, the types are
-	  ;; disjoint unless type2 is rational and type1 is integer.
+	  ;; disjoint unless type2 is RATIONAL and type1 is INTEGER.
+	  ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL
+	  ;; X X) for integral X, but this is dealt with in the
+	  ;; canonicalization inside MAKE-NUMERIC-TYPE ]
 	  ((not (or (eq class1 class2)
 		    (null class2)
-		    (and (eq class1 'integer)
-			 (eq class2 'rational))))
+		    (and (eq class1 'integer) (eq class2 'rational))))
 	   (values nil t))
 	  ;; If the float formats are specified and different, the types
 	  ;; are disjoint.
@@ -1533,28 +1546,19 @@
     (cond ((not (and low-bound high-bound)) nil)
 	  ((and (consp low-bound) (consp high-bound)) nil)
 	  ((consp low-bound)
-	   #!-negative-zero-is-not-zero
 	   (let ((low-value (car low-bound)))
 	     (or (eql low-value high-bound)
 		 (and (eql low-value -0f0) (eql high-bound 0f0))
 		 (and (eql low-value 0f0) (eql high-bound -0f0))
 		 (and (eql low-value -0d0) (eql high-bound 0d0))
-		 (and (eql low-value 0d0) (eql high-bound -0d0))))
-	   #!+negative-zero-is-not-zero
-	   (eql (car low-bound) high-bound))
+		 (and (eql low-value 0d0) (eql high-bound -0d0)))))
 	  ((consp high-bound)
-	   #!-negative-zero-is-not-zero
 	   (let ((high-value (car high-bound)))
 	     (or (eql high-value low-bound)
 		 (and (eql high-value -0f0) (eql low-bound 0f0))
 		 (and (eql high-value 0f0) (eql low-bound -0f0))
 		 (and (eql high-value -0d0) (eql low-bound 0d0))
-		 (and (eql high-value 0d0) (eql low-bound -0d0))))
-	   #!+negative-zero-is-not-zero
-	   (eql (car high-bound) low-bound))
-	  #!+negative-zero-is-not-zero
-	  ((or (and (eql low-bound -0f0) (eql high-bound 0f0))
-	       (and (eql low-bound -0d0) (eql high-bound 0d0))))
+		 (and (eql high-value 0d0) (eql low-bound -0d0)))))
 	  ((and (eq (numeric-type-class low) 'integer)
 		(eq (numeric-type-class high) 'integer))
 	   (eql (1+ low-bound) high-bound))
@@ -1563,8 +1567,10 @@
 
 ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
 ;;;
-;;; ### Note: we give up early to keep from dropping lots of information on
-;;; the floor by returning overly general types.
+;;; Old comment, probably no longer applicable:
+;;;
+;;;   ### Note: we give up early to keep from dropping lots of
+;;;   information on the floor by returning overly general types.
 (!define-type-method (number :simple-union2) (type1 type2)
   (declare (type numeric-type type1 type2))
   (cond ((csubtypep type1 type2) type2)
@@ -1576,22 +1582,65 @@
 	       (class2 (numeric-type-class type2))
 	       (format2 (numeric-type-format type2))
 	       (complexp2 (numeric-type-complexp type2)))
-	   (when (and (eq class1 class2)
-		      (eq format1 format2)
-		      (eq complexp1 complexp2)
-		      (or (numeric-types-intersect type1 type2)
-			  (numeric-types-adjacent type1 type2)
-			  (numeric-types-adjacent type2 type1)))
-	     (make-numeric-type
-	      :class class1
-	      :format format1
-	      :complexp complexp1
-	      :low (numeric-bound-max (numeric-type-low type1)
-				      (numeric-type-low type2)
-				      <= < t)
-	      :high (numeric-bound-max (numeric-type-high type1)
-				       (numeric-type-high type2)
-				       >= > t)))))))
+	   (cond
+	     ((and (eq class1 class2)
+		   (eq format1 format2)
+		   (eq complexp1 complexp2)
+		   (or (numeric-types-intersect type1 type2)
+		       (numeric-types-adjacent type1 type2)
+		       (numeric-types-adjacent type2 type1)))
+	      (make-numeric-type
+	       :class class1
+	       :format format1
+	       :complexp complexp1
+	       :low (numeric-bound-max (numeric-type-low type1)
+				       (numeric-type-low type2)
+				       <= < t)
+	       :high (numeric-bound-max (numeric-type-high type1)
+					(numeric-type-high type2)
+					>= > t)))
+	     ;; FIXME: These two clauses are almost identical, and the
+	     ;; consequents are in fact identical in every respect.
+	     ((and (eq class1 'rational)
+		   (eq class2 'integer)
+		   (eq format1 format2)
+		   (eq complexp1 complexp2)
+		   (integerp (numeric-type-low type2))
+		   (integerp (numeric-type-high type2))
+		   (= (numeric-type-low type2) (numeric-type-high type2))
+		   (or (numeric-types-adjacent type1 type2)
+		       (numeric-types-adjacent type2 type1)))
+	      (make-numeric-type
+	       :class 'rational
+	       :format format1
+	       :complexp complexp1
+	       :low (numeric-bound-max (numeric-type-low type1)
+				       (numeric-type-low type2)
+				       <= < t)
+	       :high (numeric-bound-max (numeric-type-high type1)
+					(numeric-type-high type2)
+					>= > t)))
+	     ((and (eq class1 'integer)
+		   (eq class2 'rational)
+		   (eq format1 format2)
+		   (eq complexp1 complexp2)
+		   (integerp (numeric-type-low type1))
+		   (integerp (numeric-type-high type1))
+		   (= (numeric-type-low type1) (numeric-type-high type1))
+		   (or (numeric-types-adjacent type1 type2)
+		       (numeric-types-adjacent type2 type1)))
+	      (make-numeric-type
+	       :class 'rational
+	       :format format1
+	       :complexp complexp1
+	       :low (numeric-bound-max (numeric-type-low type1)
+				       (numeric-type-low type2)
+				       <= < t)
+	       :high (numeric-bound-max (numeric-type-high type1)
+					(numeric-type-high type2)
+					>= > t)))
+	     (t nil))))))
+	      
 
 (!cold-init-forms
   (setf (info :type :kind 'number)
@@ -1701,9 +1750,6 @@
 	 (h (canonicalized-bound high 'integer))
 	 (hb (if (consp h) (1- (car h)) h)))
     (if (and hb lb (< hb lb))
-	;; previously we threw an error here:
-	;; (error "Lower bound ~S is greater than upper bound ~S." l h))
-	;; but ANSI doesn't say anything about that, so:
 	*empty-type*
       (make-numeric-type :class 'integer
 			 :complexp :real
@@ -1716,9 +1762,6 @@
      (let ((lb (canonicalized-bound low ',type))
 	   (hb (canonicalized-bound high ',type)))
        (if (not (numeric-bound-test* lb hb <= <))
-	   ;; as above, previously we did
-	   ;; (error "Lower bound ~S is not less than upper bound ~S." low high))
-	   ;; but it is correct to do
 	   *empty-type*
 	 (make-numeric-type :class ',class
 			    :format ',format
@@ -2272,6 +2315,9 @@
       (let (ms numbers)
 	(dolist (m (remove-duplicates members))
 	  (typecase m
+	    (float (if (zerop m)
+		       (push m ms)
+		       (push (ctype-of m) numbers)))
 	    (number (push (ctype-of m) numbers))
 	    (t (push m ms))))
 	(apply #'type-union
@@ -2312,15 +2358,13 @@
 ;;; shared machinery for type equality: true if every type in the set
 ;;; TYPES1 matches a type in the set TYPES2 and vice versa
 (defun type=-set (types1 types2)
-  (flet (;; true if every type in the set X matches a type in the set Y
-	 (type<=-set (x y)
+  (flet ((type<=-set (x y)
 	   (declare (type list x y))
-	   (every (lambda (xelement)
-		    (position xelement y :test #'type=))
-		  x)))
-    (values (and (type<=-set types1 types2)
-		 (type<=-set types2 types1))
-	    t)))
+	   (every/type (lambda (x y-element)
+                         (any/type #'type= y-element x))
+                       x y)))
+    (and/type (type<=-set types1 types2)
+              (type<=-set types2 types1))))
 
 ;;; Two intersection types are equal if their subtypes are equal sets.
 ;;;
@@ -2334,9 +2378,7 @@
 	     (intersection-type-types type2)))
 
 (defun %intersection-complex-subtypep-arg1 (type1 type2)
-  (any/type (swapped-args-fun #'csubtypep)
-	    type2
-	    (intersection-type-types type1)))
+  (type= type1 (type-intersection type1 type2)))
 
 (defun %intersection-simple-subtypep (type1 type2)
   (every/type #'%intersection-complex-subtypep-arg1
@@ -2378,6 +2420,28 @@
 	((and (not (intersection-type-p type1))
 	      (%intersection-complex-subtypep-arg1 type2 type1))
 	 type1)
+	;; KLUDGE: This special (and somewhat hairy) magic is required
+	;; to deal with the RATIONAL/INTEGER special case.  The UNION
+	;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER))
+	;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28
+	((and (csubtypep type2 (specifier-type 'ratio))
+	      (numeric-type-p type1)
+	      (csubtypep type1 (specifier-type 'integer))
+	      (csubtypep type2
+			 (make-numeric-type
+			  :class 'rational
+			  :complexp nil
+			  :low (if (null (numeric-type-low type1))
+				   nil
+				   (list (1- (numeric-type-low type1))))
+			  :high (if (null (numeric-type-high type1))
+				    nil
+				    (list (1+ (numeric-type-high type1)))))))
+	 (type-union type1
+		     (apply #'type-intersection
+			    (remove (specifier-type '(not integer))
+				    (intersection-type-types type2)
+				    :test #'type=))))
 	(t
 	 (let ((accumulator *universal-type*))
 	   (do ((t2s (intersection-type-types type2) (cdr t2s)))
@@ -2448,7 +2512,8 @@
 
 (!define-type-method (union :complex-=) (type1 type2)
   (declare (ignore type1))
-  (if (some #'hairy-type-p (union-type-types type2))
+  (if (some #'type-might-contain-other-types-p 
+	    (union-type-types type2))
       (values nil nil)
       (values nil t)))
 
@@ -2575,10 +2640,7 @@
 (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
   (let ((car-type (specifier-type car-type-spec))
 	(cdr-type (specifier-type cdr-type-spec)))
-    (if (or (eq car-type *empty-type*)
-	    (eq cdr-type *empty-type*))
-	*empty-type*
-	(make-cons-type car-type cdr-type))))
+    (make-cons-type car-type cdr-type)))
  
 (!define-type-method (cons :unparse) (type)
   (let ((car-eltype (type-specifier (cons-type-car-type type)))
@@ -2611,13 +2673,35 @@
 	(car-type2 (cons-type-car-type type2))
 	(cdr-type1 (cons-type-cdr-type type1))
 	(cdr-type2 (cons-type-cdr-type type2)))
-    (cond ((type= car-type1 car-type2)
-	   (make-cons-type car-type1
-			   (type-union cdr-type1 cdr-type2)))
-	  ((type= cdr-type1 cdr-type2)
-	   (make-cons-type (type-union cdr-type1 cdr-type2)
-			   cdr-type1)))))
-
+    ;; UGH.  -- CSR, 2003-02-24
+    (macrolet ((frob-car (car1 car2 cdr1 cdr2)
+		 `(type-union
+		   (make-cons-type ,car1 (type-union ,cdr1 ,cdr2))
+		   (make-cons-type
+		    (type-intersection ,car2
+		     (specifier-type
+		      `(not ,(type-specifier ,car1))))
+		    ,cdr2))))
+      (cond ((type= car-type1 car-type2)
+	     (make-cons-type car-type1
+			     (type-union cdr-type1 cdr-type2)))
+	    ((type= cdr-type1 cdr-type2)
+	     (make-cons-type (type-union car-type1 car-type2)
+			     cdr-type1))
+	    ((csubtypep car-type1 car-type2)
+	     (frob-car car-type1 car-type2 cdr-type1 cdr-type2))
+	    ((csubtypep car-type2 car-type1)
+	     (frob-car car-type2 car-type1 cdr-type2 cdr-type1))
+	    ;; Don't put these in -- consider the effect of taking the
+	    ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
+	    ;; (CONS (INTEGER 0 3) (INTEGER 5 6)).
+	    #+nil
+	    ((csubtypep cdr-type1 cdr-type2)
+	     (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2))
+	    #+nil
+	    ((csubtypep cdr-type2 cdr-type1)
+	     (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1))))))
+	    
 (!define-type-method (cons :simple-intersection2) (type1 type2)
   (declare (type cons-type type1 type2))
   (let (car-int2
@@ -2697,8 +2781,8 @@
 (defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype)
   (declare (type ctype defined-ftype declared-ftype))
   (flet ((is-built-in-class-function-p (ctype)
-	   (and (built-in-class-p ctype)
-		(eq (built-in-class-%name ctype) 'function))))
+	   (and (built-in-classoid-p ctype)
+		(eq (built-in-classoid-name ctype) 'function))))
     (cond (;; DECLARED-FTYPE could certainly be #<BUILT-IN-CLASS FUNCTION>;
 	   ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)).
 	   (is-built-in-class-function-p declared-ftype)