X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=da44cd4eee3152cb11ad6a3b781256e80c28b44c;hb=9489abab7f981b8eea2aec8a883f2eb48d4cb138;hp=8a4e03b81c480dfd10a9038d7f9329dea1cb056d;hpb=4dbc52ee4f9a4f566701f1d33e7916e8491b918b;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 8a4e03b..da44cd4 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.)
@@ -69,7 +63,7 @@
   ;; If TYPE2 might be concealing something related to our class
   ;; hierarchy
   (if (type-might-contain-other-types-p type2)
-      ;; too confusing, gotta punt 
+      ;; too confusing, gotta punt
       (values nil nil)
       ;; ordinary case expected by old CMU CL code, where the taxonomy
       ;; of TYPE2's representation accurately reflects the taxonomy of
@@ -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)))
 
@@ -102,15 +97,14 @@
 ;;;
 ;;; WHEN controls when the forms are executed.
 (defmacro !define-superclasses (type-class-name specs when)
-  (let ((type-class (gensym "TYPE-CLASS-"))
-	(info (gensym "INFO")))
+  (with-unique-names (type-class info)
     `(,when
        (let ((,type-class (type-class-or-lose ',type-class-name))
 	     (,info (mapcar (lambda (spec)
 			      (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)
@@ -156,7 +150,13 @@
   (error "SUBTYPEP is illegal on this type:~%  ~S" (type-specifier type2)))
 
 (!define-type-method (values :unparse) (type)
-  (cons 'values (unparse-args-types type)))
+  (cons 'values
+        (let ((unparsed (unparse-args-types type)))
+          (if (or (values-type-optional type)
+                  (values-type-rest type)
+                  (values-type-allowp type))
+              unparsed
+              (nconc unparsed '(&optional))))))
 
 ;;; Return true if LIST1 and LIST2 have the same elements in the same
 ;;; positions according to TYPE=. We return NIL, NIL if there is an
@@ -179,10 +179,7 @@
 (!define-type-method (values :simple-=) (type1 type2)
   (let ((rest1 (args-type-rest type1))
 	(rest2 (args-type-rest type2)))
-    (cond ((or (args-type-keyp type1) (args-type-keyp type2)
-	       (args-type-allowp type1) (args-type-allowp type2))
-	   (values nil nil))
-	  ((and rest1 rest2 (type/= rest1 rest2))
+    (cond ((and rest1 rest2 (type/= rest1 rest2))
 	   (type= rest1 rest2))
 	  ((or rest1 rest2)
 	   (values nil t))
@@ -213,11 +210,52 @@
 	    (type-specifier
 	     (fun-type-returns type)))))
 
-;;; Since all function types are equivalent to FUNCTION, they are all
-;;; subtypes of each other.
+;;; The meaning of this is a little confused. On the one hand, all
+;;; function objects are represented the same way regardless of the
+;;; arglists and return values, and apps don't get to ask things like
+;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the
+;;; other hand, Python wants to reason about function types. So...
 (!define-type-method (function :simple-subtypep) (type1 type2)
-  (declare (ignore type1 type2))
-  (values t t))
+ (flet ((fun-type-simple-p (type)
+          (not (or (fun-type-rest type)
+                   (fun-type-keyp type))))
+        (every-csubtypep (types1 types2)
+          (loop
+             for a1 in types1
+             for a2 in types2
+             do (multiple-value-bind (res sure-p)
+                    (csubtypep a1 a2)
+                  (unless res (return (values res sure-p))))
+             finally (return (values t t)))))
+   (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)
 
@@ -229,6 +267,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)
@@ -243,34 +293,7 @@
   (type= (constant-type-type type1) (constant-type-type type2)))
 
 (!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 aux)
-      (parse-lambda-list lambda-list)
-    (when aux
-      (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list))
-    (setf (args-type-required result) (mapcar #'specifier-type required))
-    (setf (args-type-optional result) (mapcar #'specifier-type optional))
-    (setf (args-type-rest result) (if restp (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 (specifier-type (second key))))))
-      (setf (args-type-keywords result) (key-info)))
-    (setf (args-type-allowp result) allowp)
-    (values)))
+  (make-constant-type :type (single-value-specifier-type type)))
 
 ;;; Return the lambda-list-like type specification corresponding
 ;;; to an ARGS-TYPE.
@@ -302,46 +325,46 @@
     (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 (coerce-to-values (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
 ;;;;
 ;;;; We provide a few special operations that can be meaningfully used
 ;;;; on VALUES types (as well as on any other type).
 
+(defun type-single-value-p (type)
+  (and (values-type-p type)
+       (not (values-type-rest type))
+       (null (values-type-optional type))
+       (singleton-p (values-type-required type))))
+
 ;;; Return the type of the first value indicated by TYPE. This is used
 ;;; by people who don't want to have to deal with VALUES types.
 #!-sb-fluid (declaim (freeze-type values-type))
 ; (inline single-value-type))
 (defun single-value-type (type)
   (declare (type ctype type))
-  (cond ((values-type-p type)
-	 (or (car (args-type-required type))
-             (if (args-type-optional type)
-                 (type-union (car (args-type-optional type))
-			     (specifier-type 'null)))
-	     (args-type-rest type)
-             (specifier-type 'null)))
-	((eq type *wild-type*)
-	 *universal-type*)
-	(t
-	 type)))
+  (cond ((eq type *wild-type*)
+         *universal-type*)
+        ((eq type *empty-type*)
+         *empty-type*)
+        ((not (values-type-p type))
+         type)
+        (t (or (car (args-type-required type))
+               (car (args-type-optional type))
+               (args-type-rest type)
+               (specifier-type 'null)))))
 
 ;;; Return the minimum number of arguments that a function can be
 ;;; called with, and the maximum number or NIL. If not a function
 ;;; 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)
@@ -356,31 +379,45 @@
 ;;; not fixed, then return NIL and :UNKNOWN.
 (defun values-types (type)
   (declare (type ctype type))
-  (cond ((eq type *wild-type*)
+  (cond ((or (eq type *wild-type*) (eq type *empty-type*))
 	 (values nil :unknown))
-	((not (values-type-p type))
-	 (values (list type) 1))
 	((or (args-type-optional type)
-	     (args-type-rest type)
-	     (args-type-keyp type)
-	     (args-type-allowp type))
+	     (args-type-rest type))
 	 (values nil :unknown))
 	(t
 	 (let ((req (args-type-required type)))
-	   (values (mapcar #'single-value-type req) (length req))))))
+	   (values req (length req))))))
 
 ;;; Return two values:
 ;;; 1. A list of all the positional (fixed and optional) types.
-;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
-;;;    If no keywords or &REST, then the DEFAULT-TYPE.
+;;; 2. The &REST type (if any). If no &REST, then the DEFAULT-TYPE.
 (defun values-type-types (type &optional (default-type *empty-type*))
-  (declare (type values-type type))
-  (values (append (args-type-required type)
-		  (args-type-optional type))
-	  (cond ((args-type-keyp type) *universal-type*)
-		((args-type-rest type))
-		(t
-		 default-type))))
+  (declare (type ctype type))
+  (if (eq type *wild-type*)
+      (values nil *universal-type*)
+      (values (append (args-type-required type)
+                      (args-type-optional type))
+              (cond ((args-type-rest type))
+                    (t default-type)))))
+
+;;; If COUNT values are supplied, which types should they have?
+(defun values-type-start (type count)
+  (declare (ctype type) (unsigned-byte count))
+  (if (eq type *wild-type*)
+      (make-list count :initial-element *universal-type*)
+      (collect ((res))
+        (flet ((process-types (types)
+                 (loop for type in types
+                       while (plusp count)
+                       do (decf count)
+                       do (res type))))
+          (process-types (values-type-required type))
+          (process-types (values-type-optional type))
+          (when (plusp count)
+            (loop with rest = (the ctype (values-type-rest type))
+                  repeat count
+                  do (res rest))))
+        (res))))
 
 ;;; Return a list of OPERATION applied to the types in TYPES1 and
 ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
@@ -401,13 +438,47 @@
 				       :initial-element rest2)))
 	    exact)))
 
-;;; If Type isn't a values type, then make it into one:
-;;;    <type>  ==>  (values type &rest t)
+;;; If TYPE isn't a values type, then make it into one.
+(defun-cached (%coerce-to-values
+               :hash-bits 8
+               :hash-function (lambda (type)
+                                (logand (type-hash-value type)
+                                        #xff)))
+    ((type eq))
+  (cond ((multiple-value-bind (res sure)
+             (csubtypep (specifier-type 'null) type)
+           (and (not res) sure))
+         ;; FIXME: What should we do with (NOT SURE)?
+         (make-values-type :required (list type) :rest *universal-type*))
+        (t
+         (make-values-type :optional (list type) :rest *universal-type*))))
+
 (defun coerce-to-values (type)
   (declare (type ctype type))
-  (if (values-type-p type)
-      type
-      (make-values-type :required (list type) :rest *universal-type*)))
+  (cond ((or (eq type *universal-type*)
+             (eq type *wild-type*))
+         *wild-type*)
+        ((values-type-p type)
+         type)
+        (t (%coerce-to-values type))))
+
+;;; Return type, corresponding to ANSI short form of VALUES type
+;;; specifier.
+(defun make-short-values-type (types)
+  (declare (list types))
+  (let ((last-required (position-if
+                        (lambda (type)
+                          (not/type (csubtypep (specifier-type 'null) type)))
+                        types
+                        :from-end t)))
+    (if last-required
+        (make-values-type :required (subseq types 0 (1+ last-required))
+                          :optional (subseq types (1+ last-required))
+                          :rest *universal-type*)
+        (make-values-type :optional types :rest *universal-type*))))
+
+(defun make-single-value-type (type)
+  (make-values-type :required (list type)))
 
 ;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
 ;;; type, including VALUES types. With VALUES types such as:
@@ -432,39 +503,31 @@
 ;;; OPERATION returned true as its second value each time we called
 ;;; it. Since we approximate the intersection of VALUES types, the
 ;;; second value being true doesn't mean the result is exact.
-(defun args-type-op (type1 type2 operation nreq default-type)
-  (declare (type ctype type1 type2 default-type)
+(defun args-type-op (type1 type2 operation nreq)
+  (declare (type ctype type1 type2)
  	   (type function operation nreq))
-  (if (or (values-type-p type1) (values-type-p type2))
-      (let ((type1 (coerce-to-values type1))
-	    (type2 (coerce-to-values type2)))
-	(multiple-value-bind (types1 rest1)
-            (values-type-types type1 default-type)
-	  (multiple-value-bind (types2 rest2)
-              (values-type-types type2 default-type)
-	    (multiple-value-bind (rest rest-exact)
-		(funcall operation rest1 rest2)
-	      (multiple-value-bind (res res-exact)
-		  (if (< (length types1) (length types2))
-		      (fixed-values-op types2 types1 rest1 operation)
-		      (fixed-values-op types1 types2 rest2 operation))
-		(let* ((req (funcall nreq
-				     (length (args-type-required type1))
-				     (length (args-type-required type2))))
-		       (required (subseq res 0 req))
-		       (opt (subseq res req))
-		       (opt-last (position rest opt :test-not #'type=
-					   :from-end t)))
-		  (if (find *empty-type* required :test #'type=)
-		      (values *empty-type* t)
-		      (values (make-values-type
-			       :required required
-			       :optional (if opt-last
-					     (subseq opt 0 (1+ opt-last))
-					     ())
-			       :rest (if (eq rest default-type) nil rest))
-			      (and rest-exact res-exact)))))))))
-      (funcall operation type1 type2)))
+  (when (eq type1 type2)
+    (values type1 t))
+  (multiple-value-bind (types1 rest1)
+      (values-type-types type1)
+    (multiple-value-bind (types2 rest2)
+        (values-type-types type2)
+      (multiple-value-bind (rest rest-exact)
+          (funcall operation rest1 rest2)
+        (multiple-value-bind (res res-exact)
+            (if (< (length types1) (length types2))
+                (fixed-values-op types2 types1 rest1 operation)
+                (fixed-values-op types1 types2 rest2 operation))
+          (let* ((req (funcall nreq
+                               (length (args-type-required type1))
+                               (length (args-type-required type2))))
+                 (required (subseq res 0 req))
+                 (opt (subseq res req)))
+            (values (make-values-type
+                     :required required
+                     :optional opt
+                     :rest rest)
+                    (and rest-exact res-exact))))))))
 
 ;;; Do a union or intersection operation on types that might be values
 ;;; types. The result is optimized for utility rather than exactness,
@@ -477,27 +540,38 @@
 				 :hash-bits 8
 				 :default nil
 				 :init-wrapper !cold-init-forms)
-	      ((type1 eq) (type2 eq))
+    ((type1 eq) (type2 eq))
   (declare (type ctype type1 type2))
   (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*)
-	((eq type1 *empty-type*) type2)
-	((eq type2 *empty-type*) type1)
-	(t
-	 (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
+        ((eq type1 *empty-type*) type2)
+        ((eq type2 *empty-type*) type1)
+        (t
+         (values (args-type-op type1 type2 #'type-union #'min)))))
+
 (defun-cached (values-type-intersection :hash-function type-cache-hash
 					:hash-bits 8
 					:values 2
 					:default (values nil :empty)
 					:init-wrapper !cold-init-forms)
-	      ((type1 eq) (type2 eq))
+    ((type1 eq) (type2 eq))
   (declare (type ctype type1 type2))
-  (cond ((eq type1 *wild-type*) (values type2 t))
-	((eq type2 *wild-type*) (values type1 t))
-	(t
-	 (args-type-op type1 type2
-		       #'type-intersection
-		       #'max
-		       (specifier-type 'null)))))
+  (cond ((eq type1 *wild-type*) (values (coerce-to-values type2) t))
+        ((or (eq type2 *wild-type*) (eq type2 *universal-type*))
+         (values type1 t))
+        ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
+         *empty-type*)
+        ((and (not (values-type-p type2))
+              (values-type-required type1))
+         (let ((req1 (values-type-required type1)))
+         (make-values-type :required (cons (type-intersection (first req1) type2)
+                                           (rest req1))
+                           :optional (values-type-optional type1)
+                           :rest (values-type-rest type1)
+                           :allowp (values-type-allowp type1))))
+        (t
+         (args-type-op type1 (coerce-to-values type2)
+                       #'type-intersection
+                       #'max))))
 
 ;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of
 ;;; works on VALUES types. Note that due to the semantics of
@@ -506,12 +580,12 @@
 (defun values-types-equal-or-intersect (type1 type2)
   (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
 	 (values t t))
-	((or (values-type-p type1) (values-type-p type2))
+        ((or (eq type1 *wild-type*) (eq type2 *wild-type*))
+         (values t t))
+	(t
 	 (multiple-value-bind (res win) (values-type-intersection type1 type2)
 	   (values (not (eq res *empty-type*))
-		   win)))
-	(t
-	 (types-equal-or-intersect type1 type2))))
+		   win)))))
 
 ;;; a SUBTYPEP-like operation that can be used on any types, including
 ;;; VALUES types
@@ -520,39 +594,39 @@
 			       :values 2
 			       :default (values nil :empty)
 			       :init-wrapper !cold-init-forms)
-	      ((type1 eq) (type2 eq))
+    ((type1 eq) (type2 eq))
   (declare (type ctype type1 type2))
-  (cond ((eq type2 *wild-type*) (values t t))
-	((eq type1 *wild-type*)
-	 (values (eq type2 *universal-type*) t))
-	((not (values-types-equal-or-intersect type1 type2))
-	 (values nil t))
-	(t
-	 (if (or (values-type-p type1) (values-type-p type2))
-	     (let ((type1 (coerce-to-values type1))
-		   (type2 (coerce-to-values type2)))
-	       (multiple-value-bind (types1 rest1) (values-type-types type1)
-		 (multiple-value-bind (types2 rest2) (values-type-types type2)
-		   (cond ((< (length (values-type-required type1))
-			     (length (values-type-required type2)))
-			  (values nil t))
-			 ((< (length types1) (length types2))
-			  (values nil nil))
-			 ((or (values-type-keyp type1)
-			      (values-type-keyp type2))
-			  (values nil nil))
-			 (t
-			  (do ((t1 types1 (rest t1))
-			       (t2 types2 (rest t2)))
-			      ((null t2)
-			       (csubtypep rest1 rest2))
-			    (multiple-value-bind (res win-p)
-				(csubtypep (first t1) (first t2))
-			      (unless win-p
-				(return (values nil nil)))
-			      (unless res
-				(return (values nil t))))))))))
-	     (csubtypep type1 type2)))))
+  (cond ((or (eq type2 *wild-type*) (eq type2 *universal-type*)
+             (eq type1 *empty-type*))
+         (values t t))
+        ((eq type1 *wild-type*)
+         (values (eq type2 *wild-type*) t))
+        ((or (eq type2 *empty-type*)
+             (not (values-types-equal-or-intersect type1 type2)))
+         (values nil t))
+        ((and (not (values-type-p type2))
+              (values-type-required type1))
+         (csubtypep (first (values-type-required type1))
+                    type2))
+        (t (setq type2 (coerce-to-values type2))
+           (multiple-value-bind (types1 rest1) (values-type-types type1)
+             (multiple-value-bind (types2 rest2) (values-type-types type2)
+               (cond ((< (length (values-type-required type1))
+                         (length (values-type-required type2)))
+                      (values nil t))
+                     ((< (length types1) (length types2))
+                      (values nil nil))
+                     (t
+                      (do ((t1 types1 (rest t1))
+                           (t2 types2 (rest t2)))
+                          ((null t2)
+                           (csubtypep rest1 rest2))
+                        (multiple-value-bind (res win-p)
+                            (csubtypep (first t1) (first t2))
+                          (unless win-p
+                            (return (values nil nil)))
+                          (unless res
+                            (return (values nil t))))))))))))
 
 ;;;; type method interfaces
 
@@ -566,9 +640,10 @@
   (declare (type ctype type1 type2))
   (cond ((or (eq type1 type2)
 	     (eq type1 *empty-type*)
-	     (eq type2 *wild-type*))
+	     (eq type2 *universal-type*))
 	 (values t t))
-	((eq type1 *wild-type*)
+        #+nil
+	((eq type1 *universal-type*)
 	 (values nil t))
 	(t
 	 (!invoke-type-method :simple-subtypep :complex-subtypep-arg2
@@ -576,12 +651,13 @@
 			      :complex-arg1 :complex-subtypep-arg1))))
 
 ;;; Just parse the type specifiers and call CSUBTYPE.
-(defun sb!xc:subtypep (type1 type2)
+(defun sb!xc:subtypep (type1 type2 &optional environment)
   #!+sb-doc
   "Return two values indicating the relationship between type1 and type2.
   If values are T and T, type1 definitely is a subtype of type2.
   If values are NIL and T, type1 definitely is not a subtype of type2.
   If values are NIL and NIL, it couldn't be determined."
+  (declare (ignore environment))
   (csubtypep (specifier-type type1) (specifier-type type2)))
 
 ;;; If two types are definitely equivalent, return true. The second
@@ -673,14 +749,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
@@ -774,71 +850,45 @@
 ;;;; These are fully general operations on CTYPEs: they'll always
 ;;;; return a CTYPE representing the result.
 
-;;; shared logic for unions and intersections: Stuff TYPE into the
-;;; vector TYPES, finding pairs of types which can be simplified by
-;;; SIMPLIFY2 (TYPE-UNION2 or TYPE-INTERSECTION2) and replacing them
-;;; by their simplified forms.
-(defun accumulate1-compound-type (type types %compound-type-p simplify2)
-  (declare (type ctype type))
-  (declare (type (vector ctype) types))
-  (declare (type function simplify2))
-  ;; Any input object satisfying %COMPOUND-TYPE-P should've been
-  ;; broken into components before it reached us.
-  (aver (not (funcall %compound-type-p type)))
-  (dotimes (i (length types) (vector-push-extend type types))
-    (let ((simplified2 (funcall simplify2 type (aref types i))))
-      (when simplified2
-	;; Discard the old (AREF TYPES I).
-	(setf (aref types i) (vector-pop types))
-	;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
-	;; (Note that the tail recursion is indirect: we go through
-	;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
-	;; handled properly if it satisfies %COMPOUND-TYPE-P.)
-	(return (accumulate-compound-type simplified2
-					  types
-					  %compound-type-p
-					  simplify2)))))
-  ;; Voila.
-  (values))
-
-;;; shared logic for unions and intersections: Use
-;;; ACCUMULATE1-COMPOUND-TYPE to merge TYPE into TYPES, either
-;;; all in one step or, if %COMPOUND-TYPE-P is satisfied,
-;;; component by component.
-(defun accumulate-compound-type (type types %compound-type-p simplify2)
-  (declare (type function %compound-type-p simplify2))
-  (flet ((accumulate1 (x)
-	   (accumulate1-compound-type x types %compound-type-p simplify2)))
-    (declare (inline accumulate1))
-    (if (funcall %compound-type-p type)
-	(map nil #'accumulate1 (compound-type-types type))
-	(accumulate1 type)))
-  (values))
-
 ;;; shared logic for unions and intersections: Return a vector of
-;;; types representing the same types as INPUT-TYPES, but with 
+;;; types representing the same types as INPUT-TYPES, but with
 ;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their
 ;;; component types, and with any SIMPLY2 simplifications applied.
+(declaim (inline simplified-compound-types))
 (defun simplified-compound-types (input-types %compound-type-p simplify2)
-  (let ((simplified-types (make-array (length input-types)
-				      :fill-pointer 0
-				      :adjustable t
-				      :element-type 'ctype
-				      ;; (This INITIAL-ELEMENT shouldn't
-				      ;; matter, but helps avoid type
-				      ;; warnings at compile time.)
-				      :initial-element *empty-type*)))
-    (dolist (input-type input-types)
-      (accumulate-compound-type input-type
-				simplified-types
-				%compound-type-p
-				simplify2))
-    simplified-types))
+  (declare (function %compound-type-p simplify2))
+  (let ((types (make-array (length input-types)
+                           :fill-pointer 0
+                           :adjustable t
+                           :element-type 'ctype)))
+    (labels ((accumulate-compound-type (type)
+               (if (funcall %compound-type-p type)
+                   (dolist (type (compound-type-types type))
+                     (accumulate1-compound-type type))
+                   (accumulate1-compound-type type)))
+             (accumulate1-compound-type (type)
+               (declare (type ctype type))
+               ;; Any input object satisfying %COMPOUND-TYPE-P should've been
+               ;; broken into components before it reached us.
+               (aver (not (funcall %compound-type-p type)))
+               (dotimes (i (length types) (vector-push-extend type types))
+                 (let ((simplified2 (funcall simplify2 type (aref types i))))
+                   (when simplified2
+                     ;; Discard the old (AREF TYPES I).
+                     (setf (aref types i) (vector-pop types))
+                     ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
+                     ;; (Note that the tail recursion is indirect: we go through
+                     ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
+                     ;; handled properly if it satisfies %COMPOUND-TYPE-P.)
+                     (return (accumulate-compound-type simplified2)))))))
+      (dolist (input-type input-types)
+        (accumulate-compound-type input-type)))
+    types))
 
 ;;; 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))
@@ -852,7 +902,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.
@@ -870,6 +920,11 @@
 	nil)))
 
 (defun type-intersection (&rest input-types)
+  (%type-intersection input-types))
+(defun-cached (%type-intersection :hash-bits 8
+                                  :hash-function (lambda (x)
+                                                   (logand (sxhash x) #xff)))
+    ((input-types equal))
   (let ((simplified-types (simplified-compound-types input-types
 						     #'intersection-type-p
 						     #'type-intersection2)))
@@ -885,26 +940,35 @@
     (if (and (> (length simplified-types) 1)
 	     (some #'union-type-p simplified-types))
 	(let* ((first-union (find-if #'union-type-p simplified-types))
-	       (other-types (coerce (remove first-union simplified-types) 'list))
-	       (distributed (maybe-distribute-one-union first-union other-types)))
+	       (other-types (coerce (remove first-union simplified-types)
+				    'list))
+	       (distributed (maybe-distribute-one-union first-union
+							other-types)))
 	  (if distributed
 	      (apply #'type-union distributed)
 	      (make-hairy-type
-	       :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*))))
+	       :specifier `(and ,@(map 'list
+				       #'type-specifier
+				       simplified-types)))))
+	(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))
+(defun-cached (%type-union :hash-bits 8
+                           :hash-function (lambda (x)
+                                            (logand (sxhash x) #xff)))
+    ((input-types equal))
   (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
 
@@ -914,18 +978,18 @@
 (defvar *empty-type*)
 (defvar *universal-type*)
 (defvar *universal-fun-type*)
+
 (!cold-init-forms
  (macrolet ((frob (name var)
 	      `(progn
-		 (setq ,var (make-named-type :name ',name))
-		 (setf (info :type :kind ',name) #+sb-xc-host :defined #-sb-xc-host :primitive)
+                 (setq ,var (make-named-type :name ',name))
+		 (setf (info :type :kind ',name)
+		       #+sb-xc-host :defined #-sb-xc-host :primitive)
 		 (setf (info :type :builtin ',name) ,var))))
    ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
    ;; special symbol which can be stuck in some places where an
    ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).
-   ;; At some point, in order to become more standard, we should
-   ;; convert all the classic CMU CL legacy *s and *WILD-TYPE*s into
-   ;; Ts and *UNIVERSAL-TYPE*s.
+   ;; In SBCL it also used to denote universal VALUES type.
    (frob * *wild-type*)
    (frob nil *empty-type*)
    (frob t *universal-type*))
@@ -934,12 +998,26 @@
 		      :returns *wild-type*)))
 
 (!define-type-method (named :simple-=) (type1 type2)
-  ;; FIXME: BUG 85: This assertion failed when I added it in
-  ;; sbcl-0.6.11.13. It probably shouldn't fail; but for now it's
-  ;; just commented out.
   ;;(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))
@@ -970,7 +1048,7 @@
 	 (values nil nil))
 	(t
 	 ;; By elimination, TYPE1 is the universal type.
-	 (aver (or (eq type1 *wild-type*) (eq type1 *universal-type*)))
+	 (aver (eq type1 *universal-type*))
 	 ;; This case would have been picked off by the SIMPLE-SUBTYPEP
 	 ;; method, and so shouldn't appear here.
 	 (aver (not (eq type2 *universal-type*)))
@@ -982,11 +1060,13 @@
   (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
-	 ;; HAIRY-TYPE values, and the exclusion of various
+	 ;; NAMED-TYPE values, and the exclusion of various
 	 ;; possibilities above. It would be good to explain it and/or
 	 ;; rewrite it so that it's clearer.
 	 (values (not (eq type2 *empty-type*)) t))))
@@ -1007,151 +1087,46 @@
 
 ;;;; hairy and unknown types
 
-(!define-type-method (hairy :unparse) (x) (hairy-type-specifier x))
+(!define-type-method (hairy :unparse) (x)
+  (hairy-type-specifier x))
 
 (!define-type-method (hairy :simple-subtypep) (type1 type2)
   (let ((hairy-spec1 (hairy-type-specifier type1))
 	(hairy-spec2 (hairy-type-specifier type2)))
-    (cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not)
-		(consp hairy-spec2) (eq (car hairy-spec2) 'not))
-	   (csubtypep (specifier-type (cadr hairy-spec2))
-		      (specifier-type (cadr hairy-spec1))))
-	  ((equal hairy-spec1 hairy-spec2)
+    (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2)
 	   (values t t))
 	  (t
 	   (values nil nil)))))
 
 (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
-  (let ((hairy-spec (hairy-type-specifier type2)))
-    (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
-	   (let* ((complement-type2 (specifier-type (cadr hairy-spec)))
-		  (intersection2 (type-intersection2 type1
-						     complement-type2)))
-	     (if intersection2
-		 (values (eq intersection2 *empty-type*) t)
-		 (invoke-complex-subtypep-arg1-method type1 type2))))
-	  (t
-	   (invoke-complex-subtypep-arg1-method type1 type2)))))
+  (invoke-complex-subtypep-arg1-method type1 type2))
 
 (!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
-  ;; "Incrementally extended heuristic algorithms tend inexorably toward the
-  ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
-  (let ((hairy-spec (hairy-type-specifier type1)))
-     (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
-	    ;; You may not believe this. I couldn't either. But then I
-	    ;; sat down and drew lots of Venn diagrams. Comments
-	    ;; involving a and b refer to the call (subtypep '(not a)
-	    ;; 'b) -- CSR, 2002-02-27.
-	    (block nil
-	      ;; (Several logical truths in this block are true as
-	      ;; long as b/=T. As of sbcl-0.7.1.28, it seems
-	      ;; impossible to construct a case with b=T where we
-	      ;; actually reach this type method, but we'll test for
-	      ;; and exclude this case anyway, since future
-	      ;; maintenance might make it possible for it to end up
-	      ;; in this code.)
-	      (multiple-value-bind (equal certain)
-		  (type= type2 (specifier-type t))
-		(unless certain
-		  (return (values nil nil)))
-		(when equal
-		  (return (values t t))))
-	      (let ((complement-type1 (specifier-type (cadr hairy-spec))))
-		;; Do the special cases first, in order to give us a
-		;; chance if subtype/supertype relationships are hairy.
-		(multiple-value-bind (equal certain) 
-		    (type= complement-type1 type2)
-		  ;; If a = b, ~a is not a subtype of b (unless b=T,
-		  ;; which was excluded above).
-		  (unless certain
-		    (return (values nil nil)))
-		  (when equal
-		    (return (values nil t))))
-		;; KLUDGE: ANSI requires that the SUBTYPEP result
-		;; between any two built-in atomic type specifiers
-		;; never be uncertain. This is hard to do cleanly for
-		;; the built-in types whose definitions include
-		;; (NOT FOO), i.e. CONS and RATIO. However, we can do
-		;; it with this hack, which uses our global knowledge
-		;; that our implementation of the type system uses
-		;; disjoint implementation types to represent disjoint
-		;; sets (except when types are contained in other types).
-		;; (This is a KLUDGE because it's fragile. Various
-		;; changes in internal representation in the type
-		;; system could make it start confidently returning
-		;; incorrect results.) -- WHN 2002-03-08
-		(unless (or (type-might-contain-other-types-p complement-type1)
-			    (type-might-contain-other-types-p type2))
-		  ;; Because of the way our types which don't contain
-		  ;; other types are disjoint subsets of the space of
-		  ;; possible values, (SUBTYPEP '(NOT AA) 'B)=NIL when
-		  ;; AA and B are simple (and B is not T, as checked above).
-		  (return (values nil t)))
-		;; The old (TYPE= TYPE1 TYPE2) branch would never be
-		;; taken, as TYPE1 and TYPE2 will only be equal if
-		;; they're both NOT types, and then the
-		;; :SIMPLE-SUBTYPEP method would be used instead.
-		;; But a CSUBTYPEP relationship might still hold:
-		(multiple-value-bind (equal certain)
-		    (csubtypep complement-type1 type2)
-		  ;; If a is a subtype of b, ~a is not a subtype of b
-		  ;; (unless b=T, which was excluded above).
-		  (unless certain
-		    (return (values nil nil)))
-		  (when equal
-		    (return (values nil t))))
-		(multiple-value-bind (equal certain)
-		    (csubtypep type2 complement-type1)
-		  ;; If b is a subtype of a, ~a is not a subtype of b.
-		  ;; (FIXME: That's not true if a=T. Do we know at
-		  ;; this point that a is not T?)
-		  (unless certain
-		    (return (values nil nil)))
-		  (when equal
-		    (return (values nil t))))
-		;; old CSR comment ca. 0.7.2, now obsoleted by the
-		;; SIMPLE-CTYPE? KLUDGE case above:
-		;;   Other cases here would rely on being able to catch
-		;;   all possible cases, which the fragility of this
-		;;   type system doesn't inspire me; for instance, if a
-		;;   is type= to ~b, then we want T, T; if this is not
-		;;   the case and the types are disjoint (have an
-		;;   intersection of *empty-type*) then we want NIL, T;
-		;;   else if the union of a and b is the
-		;;   *universal-type* then we want T, T. So currently we
-		;;   still claim to be unsure about e.g. (subtypep '(not
-		;;   fixnum) 'single-float).
-		)))
-	   (t
-	    (values nil nil)))))
+  (declare (ignore type1 type2))
+  (values nil nil))
 
 (!define-type-method (hairy :complex-=) (type1 type2)
   (declare (ignore type1 type2))
   (values nil nil))
 
-(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
+(!define-type-method (hairy :simple-intersection2 :complex-intersection2) 
+		     (type1 type2)
+  (if (type= type1 type2)
+      type1
+      nil))
+
+(!define-type-method (hairy :simple-union2) 
 		     (type1 type2)
   (if (type= type1 type2)
       type1
       nil))
 
 (!define-type-method (hairy :simple-=) (type1 type2)
-  (if (equal (hairy-type-specifier type1)
-	     (hairy-type-specifier type2))
+  (if (equal-but-no-car-recursion (hairy-type-specifier type1)
+				  (hairy-type-specifier type2))
       (values t t)
       (values nil nil)))
 
-(!def-type-translator not (&whole whole type)
-  (declare (ignore type))
-  ;; Check legality of arguments.
-  (destructuring-bind (not typespec) whole
-    (declare (ignore not))
-    (let ((spec (type-specifier (specifier-type typespec)))) ; must be legal typespec
-      (if (and (listp spec) (eq (car spec) 'not))
-	  ;; canonicalize (not (not foo))
-	  (specifier-type (cadr spec))
-	  (make-hairy-type :specifier whole)))))
-
 (!def-type-translator satisfies (&whole whole fun)
   (declare (ignore fun))
   ;; Check legality of arguments.
@@ -1161,11 +1136,283 @@
       (error 'simple-type-error
 	     :datum predicate-name
 	     :expected-type 'symbol
-	     :format-control "~S is not a symbol."
+	     :format-control "The SATISFIES predicate name is not a symbol: ~S"
 	     :format-arguments (list predicate-name))))
   ;; Create object.
   (make-hairy-type :specifier whole))
 
+;;;; negation types
+
+(!define-type-method (negation :unparse) (x)
+  `(not ,(type-specifier (negation-type-type x))))
+
+(!define-type-method (negation :simple-subtypep) (type1 type2)
+  (csubtypep (negation-type-type type2) (negation-type-type type1)))
+
+(!define-type-method (negation :complex-subtypep-arg2) (type1 type2)
+  (let* ((complement-type2 (negation-type-type type2))
+	 (intersection2 (type-intersection2 type1
+					    complement-type2)))
+    (if intersection2
+	;; 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)
+  ;; "Incrementally extended heuristic algorithms tend inexorably toward the
+  ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt
+  ;;
+  ;; You may not believe this. I couldn't either. But then I sat down
+  ;; and drew lots of Venn diagrams. Comments involving a and b refer
+  ;; to the call (subtypep '(not a) 'b) -- CSR, 2002-02-27.
+  (block nil
+    ;; (Several logical truths in this block are true as long as
+    ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a
+    ;; case with b=T where we actually reach this type method, but
+    ;; we'll test for and exclude this case anyway, since future
+    ;; maintenance might make it possible for it to end up in this
+    ;; code.)
+    (multiple-value-bind (equal certain)
+	(type= type2 *universal-type*)
+      (unless certain
+	(return (values nil nil)))
+      (when equal
+	(return (values t t))))
+    (let ((complement-type1 (negation-type-type type1)))
+      ;; Do the special cases first, in order to give us a chance if
+      ;; subtype/supertype relationships are hairy.
+      (multiple-value-bind (equal certain)
+	  (type= complement-type1 type2)
+	;; If a = b, ~a is not a subtype of b (unless b=T, which was
+	;; excluded above).
+	(unless certain
+	  (return (values nil nil)))
+	(when equal
+	  (return (values nil t))))
+      ;; KLUDGE: ANSI requires that the SUBTYPEP result between any
+      ;; two built-in atomic type specifiers never be uncertain. This
+      ;; is hard to do cleanly for the built-in types whose
+      ;; definitions include (NOT FOO), i.e. CONS and RATIO. However,
+      ;; we can do it with this hack, which uses our global knowledge
+      ;; that our implementation of the type system uses disjoint
+      ;; implementation types to represent disjoint sets (except when
+      ;; types are contained in other types).  (This is a KLUDGE
+      ;; because it's fragile. Various changes in internal
+      ;; representation in the type system could make it start
+      ;; confidently returning incorrect results.) -- WHN 2002-03-08
+      (unless (or (type-might-contain-other-types-p complement-type1)
+		  (type-might-contain-other-types-p type2))
+	;; Because of the way our types which don't contain other
+	;; types are disjoint subsets of the space of possible values,
+	;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B
+	;; is not T, as checked above).
+	(return (values nil t)))
+      ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as
+      ;; TYPE1 and TYPE2 will only be equal if they're both NOT types,
+      ;; and then the :SIMPLE-SUBTYPEP method would be used instead.
+      ;; But a CSUBTYPEP relationship might still hold:
+      (multiple-value-bind (equal certain)
+	  (csubtypep complement-type1 type2)
+	;; If a is a subtype of b, ~a is not a subtype of b (unless
+	;; b=T, which was excluded above).
+	(unless certain
+	  (return (values nil nil)))
+	(when equal
+	  (return (values nil t))))
+      (multiple-value-bind (equal certain)
+	  (csubtypep type2 complement-type1)
+	;; If b is a subtype of a, ~a is not a subtype of b.  (FIXME:
+	;; That's not true if a=T. Do we know at this point that a is
+	;; not T?)
+	(unless certain
+	  (return (values nil nil)))
+	(when equal
+	  (return (values nil t))))
+      ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE?
+      ;; KLUDGE case above: Other cases here would rely on being able
+      ;; to catch all possible cases, which the fragility of this type
+      ;; system doesn't inspire me; for instance, if a is type= to ~b,
+      ;; then we want T, T; if this is not the case and the types are
+      ;; disjoint (have an intersection of *empty-type*) then we want
+      ;; NIL, T; else if the union of a and b is the *universal-type*
+      ;; then we want T, T. So currently we still claim to be unsure
+      ;; about e.g. (subtypep '(not fixnum) 'single-float).
+      ;;
+      ;; OTOH we might still get here:
+      (values nil nil))))
+
+(!define-type-method (negation :complex-=) (type1 type2)
+  ;; (NOT FOO) isn't equivalent to anything that's not a negation
+  ;; type, except possibly a type that might contain it in disguise.
+  (declare (ignore type2))
+  (if (type-might-contain-other-types-p type1)
+      (values nil nil)
+      (values nil t)))
+
+(!define-type-method (negation :simple-intersection2) (type1 type2)
+  (let ((not1 (negation-type-type type1))
+	(not2 (negation-type-type type2)))
+    (cond
+      ((csubtypep not1 not2) type2)
+      ((csubtypep not2 not1) type1)
+      ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2
+      ;; method, below?  The clause would read
+      ;;
+      ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*)
+      ;;
+      ;; but with proper canonicalization of negation types, there's
+      ;; no way of constructing two negation types with union of their
+      ;; negations being the universal type.
+      (t
+       (aver (not (eq (type-union not1 not2) *universal-type*)))
+       nil))))
+
+(!define-type-method (negation :complex-intersection2) (type1 type2)
+  (cond
+    ((csubtypep type1 (negation-type-type type2)) *empty-type*)
+    ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
+     type1)
+    (t nil)))
+
+(!define-type-method (negation :simple-union2) (type1 type2)
+  (let ((not1 (negation-type-type type1))
+	(not2 (negation-type-type type2)))
+    (cond
+      ((csubtypep not1 not2) type1)
+      ((csubtypep not2 not1) type2)
+      ((eq (type-intersection not1 not2) *empty-type*)
+       *universal-type*)
+      (t nil))))
+
+(!define-type-method (negation :complex-union2) (type1 type2)
+  (cond
+    ((csubtypep (negation-type-type type2) type1) *universal-type*)
+    ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*)
+     type2)
+    (t nil)))
+
+(!define-type-method (negation :simple-=) (type1 type2)
+  (type= (negation-type-type type1) (negation-type-type type2)))
+
+(!def-type-translator not (typespec)
+  (let* ((not-type (specifier-type typespec))
+	 (spec (type-specifier not-type)))
+    (cond
+      ;; canonicalize (NOT (NOT FOO))
+      ((and (listp spec) (eq (car spec) 'not))
+       (specifier-type (cadr spec)))
+      ;; canonicalize (NOT NIL) and (NOT T)
+      ((eq not-type *empty-type*) *universal-type*)
+      ((eq not-type *universal-type*) *empty-type*)
+      ((and (numeric-type-p not-type)
+	    (null (numeric-type-low not-type))
+	    (null (numeric-type-high not-type)))
+       (make-negation-type :type not-type))
+      ((numeric-type-p not-type)
+       (type-union
+	(make-negation-type
+	 :type (modified-numeric-type not-type :low nil :high nil))
+	(cond
+	  ((null (numeric-type-low not-type))
+	   (modified-numeric-type
+	    not-type
+	    :low (let ((h (numeric-type-high not-type)))
+		   (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) (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) (car l) (list l))))
+	      (modified-numeric-type
+	       not-type
+	       :low (let ((h (numeric-type-high not-type)))
+		      (if (consp h) (car h) (list h)))
+	       :high nil))))))
+      ((intersection-type-p not-type)
+       (apply #'type-union
+	      (mapcar #'(lambda (x)
+			  (specifier-type `(not ,(type-specifier x))))
+		      (intersection-type-types not-type))))
+      ((union-type-p not-type)
+       (apply #'type-intersection
+	      (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 . ,(load-time-value (make-unportable-float :single-float-negative-zero)))
+			       (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero)))
+			       #!+long-float
+			       (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero)))))
+		 (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
 
 (!define-type-class number)
@@ -1175,8 +1422,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)
@@ -1236,7 +1483,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)
@@ -1249,32 +1495,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)
@@ -1287,19 +1513,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
@@ -1333,11 +1546,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.
@@ -1351,7 +1566,7 @@
 	  (t
 	   (values nil t)))))
 
-(!define-superclasses number ((generic-number)) !cold-init-forms)
+(!define-superclasses number ((number)) !cold-init-forms)
 
 ;;; If the high bound of LOW is adjacent to the low bound of HIGH,
 ;;; then return true, otherwise NIL.
@@ -1361,28 +1576,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 (load-time-value (make-unportable-float :single-float-negative-zero))) (eql high-bound 0f0))
+		 (and (eql low-value 0f0) (eql high-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
+		 (and (eql low-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql high-bound 0d0))
+		 (and (eql low-value 0d0) (eql high-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
 	  ((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 (load-time-value (make-unportable-float :single-float-negative-zero))) (eql low-bound 0f0))
+		 (and (eql high-value 0f0) (eql low-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
+		 (and (eql high-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql low-bound 0d0))
+		 (and (eql high-value 0d0) (eql low-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))
 	  ((and (eq (numeric-type-class low) 'integer)
 		(eq (numeric-type-class high) 'integer))
 	   (eql (1+ low-bound) high-bound))
@@ -1391,8 +1597,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)
@@ -1404,25 +1612,69 @@
 	       (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) #+sb-xc-host :defined #-sb-xc-host :primitive)
+  (setf (info :type :kind 'number)
+	#+sb-xc-host :defined #-sb-xc-host :primitive)
   (setf (info :type :builtin 'number)
 	(make-numeric-type :complexp nil)))
 
@@ -1528,10 +1780,7 @@
 	 (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:
-	(specifier-type 'nil)
+	*empty-type*
       (make-numeric-type :class 'integer
 			 :complexp :real
 			 :enumerable (not (null (and l h)))
@@ -1543,11 +1792,11 @@
      (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
-	   (specifier-type 'nil)
-	 (make-numeric-type :class ',class :format ',format :low lb :high hb)))))
+	   *empty-type*
+	 (make-numeric-type :class ',class
+			    :format ',format
+			    :low lb
+			    :high hb)))))
 
 (!def-bounded-type rational rational nil)
 
@@ -2017,9 +2266,10 @@
 
 (!define-type-method (member :unparse) (type)
   (let ((members (member-type-members type)))
-    (if (equal members '(nil))
-	'null
-	`(member ,@members))))
+    (cond
+      ((equal members '(nil)) 'null)
+      ((type= type (specifier-type 'standard-char)) 'standard-char)
+      (t `(member ,@members)))))
 
 (!define-type-method (member :simple-subtypep) (type1 type2)
   (values (subsetp (member-type-members type1) (member-type-members type2))
@@ -2051,7 +2301,7 @@
 		 *empty-type*))))))
 
 (!define-type-method (member :complex-intersection2) (type1 type2)
-  (block punt		     
+  (block punt
     (collect ((members))
       (let ((mem2 (member-type-members type2)))
         (dolist (member mem2)
@@ -2092,8 +2342,20 @@
 
 (!def-type-translator member (&rest members)
   (if members
-    (make-member-type :members (remove-duplicates members))
-    *empty-type*))
+      (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
+	       (if ms
+		   (make-member-type :members ms)
+		   *empty-type*)
+	       (nreverse numbers)))
+      *empty-type*))
 
 ;;;; intersection types
 ;;;;
@@ -2120,21 +2382,19 @@
 ;;; mechanically unparsed.
 (!define-type-method (intersection :unparse) (type)
   (declare (type ctype type))
-  (or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=)
+  (or (find type '(ratio keyword) :key #'specifier-type :test #'type=)
       `(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
 
 ;;; 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.
 ;;;
@@ -2148,21 +2408,94 @@
 	     (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)))
 
-(!define-type-method (intersection :simple-subtypep) (type1 type2)
+(defun %intersection-simple-subtypep (type1 type2)
   (every/type #'%intersection-complex-subtypep-arg1
 	      type1
 	      (intersection-type-types type2)))
 
+(!define-type-method (intersection :simple-subtypep) (type1 type2)
+  (%intersection-simple-subtypep type1 type2))
+  
 (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
   (%intersection-complex-subtypep-arg1 type1 type2))
 
-(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
+(defun %intersection-complex-subtypep-arg2 (type1 type2)
   (every/type #'csubtypep type1 (intersection-type-types type2)))
 
+(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
+  (%intersection-complex-subtypep-arg2 type1 type2))
+
+;;; FIXME: This will look eeriely familiar to readers of the UNION
+;;; :SIMPLE-INTERSECTION2 :COMPLEX-INTERSECTION2 method.  That's
+;;; because it was generated by cut'n'paste methods.  Given that
+;;; intersections and unions have all sorts of symmetries known to
+;;; mathematics, it shouldn't be beyond the ken of some programmers to
+;;; reflect those symmetries in code in a way that ties them together
+;;; more strongly than having two independent near-copies :-/
+(!define-type-method (intersection :simple-union2 :complex-union2)
+ 		     (type1 type2)
+  ;; Within this method, type2 is guaranteed to be an intersection
+  ;; type:
+  (aver (intersection-type-p type2))
+  ;; Make sure to call only the applicable methods...
+  (cond ((and (intersection-type-p type1)
+	      (%intersection-simple-subtypep type1 type2)) type2)
+	((and (intersection-type-p type1)
+	      (%intersection-simple-subtypep type2 type1)) type1)
+	((and (not (intersection-type-p type1))
+	      (%intersection-complex-subtypep-arg2 type1 type2))
+	 type2)
+	((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)))
+	       ((null t2s) accumulator)
+	     (let ((union (type-union type1 (car t2s))))
+	       (when (union-type-p union)
+		 ;; we have to give up here -- there are all sorts of
+		 ;; ordering worries, but it's better than before.
+		 ;; Doing exactly the same as in the UNION
+		 ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack
+		 ;; overflow with the mutual recursion never bottoming
+		 ;; out.
+		 (if (and (eq accumulator *universal-type*)
+			  (null (cdr t2s)))
+		     ;; KLUDGE: if we get here, we have a partially
+		     ;; simplified result.  While this isn't by any
+		     ;; means a universal simplification, including
+		     ;; this logic here means that we can get (OR
+		     ;; KEYWORD (NOT KEYWORD)) canonicalized to T.
+		     (return union)
+		     (return nil)))
+	       (setf accumulator
+		     (type-intersection accumulator union))))))))
+
 (!def-type-translator and (&whole whole &rest type-specifiers)
   (apply #'type-intersection
 	 (mapcar #'specifier-type
@@ -2172,13 +2505,17 @@
 
 (!define-type-class union)
 
-;;; The LIST type has a special name. Other union types just get
-;;; mechanically unparsed.
+;;; The LIST, FLOAT and REAL types have special names.  Other union
+;;; types just get mechanically unparsed.
 (!define-type-method (union :unparse) (type)
   (declare (type ctype type))
-  (if (type= type (specifier-type 'list))
-      'list
-      `(or ,@(mapcar #'type-specifier (union-type-types type)))))
+  (cond
+    ((type= type (specifier-type 'list)) 'list)
+    ((type= type (specifier-type 'float)) 'float)
+    ((type= type (specifier-type 'real)) 'real)
+    ((type= type (specifier-type 'sequence)) 'sequence)
+    ((type= type (specifier-type 'bignum)) 'bignum)
+    (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
 
 ;;; Two union types are equal if they are each subtypes of each
 ;;; other. We need to be this clever because our complex subtypep
@@ -2205,7 +2542,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)))
 
@@ -2317,12 +2655,8 @@
 	 (let ((accumulator *empty-type*))
 	   (dolist (t2 (union-type-types type2) accumulator)
 	     (setf accumulator
-		   (type-union2 accumulator
-				(type-intersection type1 t2)))
-	     ;; When our result isn't simple any more (because
-	     ;; TYPE-UNION2 was unable to give us a simple result)
-	     (unless accumulator
-	       (return nil)))))))
+		   (type-union accumulator
+			       (type-intersection type1 t2))))))))
 
 (!def-type-translator or (&rest type-specifiers)
   (apply #'type-union
@@ -2334,8 +2668,9 @@
 (!define-type-class cons)
 
 (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*))
-  (make-cons-type (specifier-type car-type-spec)
-		  (specifier-type cdr-type-spec)))
+  (let ((car-type (single-value-specifier-type car-type-spec))
+	(cdr-type (single-value-specifier-type cdr-type-spec)))
+    (make-cons-type car-type cdr-type)))
  
 (!define-type-method (cons :unparse) (type)
   (let ((car-eltype (type-specifier (cons-type-car-type type)))
@@ -2368,13 +2703,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
@@ -2437,14 +2794,19 @@
 				       (dimensions '*))
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
-		    :element-type (specifier-type element-type))))
+                    :complexp :maybe
+		    :element-type (if (eq element-type '*)
+                                      *wild-type*
+                                      (specifier-type element-type)))))
 
 (!def-type-translator simple-array (&optional (element-type '*)
 					      (dimensions '*))
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
-		    :element-type (specifier-type element-type)
-		    :complexp nil)))
+                    :complexp nil
+		    :element-type (if (eq element-type '*)
+                                      *wild-type*
+                                      (specifier-type element-type)))))
 
 ;;;; utilities shared between cross-compiler and target system
 
@@ -2453,8 +2815,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)