X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=20da7651dd93290e5dfb0c2ce3b60e90e0b7218e;hb=f0670f28705c01e79fb23cb2a582074d3e51ec98;hp=863f2487fff50a861c7cd692d3cd57c37670be62;hpb=3aff5655417da74a19ce576f55b2cb6999cda6c5;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 863f248..20da765 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -16,6 +16,8 @@
 
 (in-package "SB!KERNEL")
 
+(/show0 "late-type.lisp 19")
+
 (!begin-collecting-cold-init-forms)
 
 ;;; ### Remaining incorrectnesses:
@@ -55,20 +57,18 @@
     (if subtypep-arg1
 	(funcall subtypep-arg1 type1 type2)
 	(values nil t))))
-(defun delegate-complex-intersection (type1 type2)
-  (let ((method (type-class-complex-intersection (type-class-info type1))))
-    (if (and method (not (eq method #'delegate-complex-intersection)))
+(defun delegate-complex-intersection2 (type1 type2)
+  (let ((method (type-class-complex-intersection2 (type-class-info type1))))
+    (if (and method (not (eq method #'delegate-complex-intersection2)))
 	(funcall method type2 type1)
-	(vanilla-intersection type1 type2))))
-
-;;; This is used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
-;;; method. INFO is a list of conses (SUPERCLASS-CLASS .
-;;; {GUARD-TYPE-SPECIFIER | NIL}). This will never be called with a
-;;; hairy type as TYPE2, since the hairy type TYPE2 method gets first
-;;; crack.
-;;;
-;;; FIXME: Declare this as INLINE, since it's only used in one place.
-(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info)
+	(hierarchical-intersection2 type1 type2))))
+
+;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
+;;; method. INFO is a list of conses
+;;;   (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}).
+;;; This will never be called with a hairy type as TYPE2, since the
+;;; hairy type TYPE2 method gets first crack.
+(defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info)
   (values
    (and (sb!xc:typep type2 'sb!xc:class)
 	(dolist (x info nil)
@@ -94,7 +94,7 @@
 ;;;    G0,(and G1 (not G0)), (and G2 (not (or G0 G1))).
 ;;;
 ;;; WHEN controls when the forms are executed.
-(defmacro define-superclasses (type-class-name specs when)
+(defmacro !define-superclasses (type-class-name specs when)
   (let ((type-class (gensym "TYPE-CLASS-"))
 	(info (gensym "INFO")))
     `(,when
@@ -107,11 +107,11 @@
 			    ',specs)))
 	 (setf (type-class-complex-subtypep-arg1 ,type-class)
 	       (lambda (type1 type2)
-		 (has-superclasses-complex-subtypep-arg1 type1 type2 ,info)))
+		 (!has-superclasses-complex-subtypep-arg1 type1 type2 ,info)))
 	 (setf (type-class-complex-subtypep-arg2 ,type-class)
 	       #'delegate-complex-subtypep-arg2)
-	 (setf (type-class-complex-intersection ,type-class)
-	       #'delegate-complex-intersection)))))
+	 (setf (type-class-complex-intersection2 ,type-class)
+	       #'delegate-complex-intersection2)))))
 
 ;;;; FUNCTION and VALUES types
 ;;;;
@@ -129,24 +129,26 @@
 ;;;; -- Many of the places that can be annotated with real types can
 ;;;;    also be annotated with function or values types.
 
-;;; the description of a keyword argument
-(defstruct (key-info #-sb-xc-host (:pure t))
-  ;; the keyword
-  (name (required-argument) :type keyword)
+;;; the description of a &KEY argument
+(defstruct (key-info #-sb-xc-host (:pure t)
+		     (:copier nil))
+  ;; the key (not necessarily a keyword in ANSI)
+  (name (required-argument) :type symbol)
   ;; the type of the argument value
   (type (required-argument) :type ctype))
 
-(define-type-method (values :simple-subtypep :complex-subtypep-arg1)
-		    (type1 type2)
+(!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
+		     (type1 type2)
   (declare (ignore type2))
-  (error "Subtypep is illegal on this type:~%  ~S" (type-specifier type1)))
+  ;; FIXME: should be TYPE-ERROR, here and in next method
+  (error "SUBTYPEP is illegal on this type:~%  ~S" (type-specifier type1)))
 
-(define-type-method (values :complex-subtypep-arg2)
-		    (type1 type2)
+(!define-type-method (values :complex-subtypep-arg2)
+		     (type1 type2)
   (declare (ignore type1))
-  (error "Subtypep is illegal on this type:~%  ~S" (type-specifier type2)))
+  (error "SUBTYPEP is illegal on this type:~%  ~S" (type-specifier type2)))
 
-(define-type-method (values :unparse) (type)
+(!define-type-method (values :unparse) (type)
   (cons 'values (unparse-args-types type)))
 
 ;;; Return true if LIST1 and LIST2 have the same elements in the same
@@ -167,7 +169,7 @@
       (unless val
 	(return (values nil t))))))
 
-(define-type-method (values :simple-=) (type1 type2)
+(!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)
@@ -186,7 +188,7 @@
 			     (values-type-optional type2))
 	       (values (and req-val opt-val) (and req-win opt-win))))))))
 
-(define-type-class function)
+(!define-type-class function)
 
 ;;; a flag that we can bind to cause complex function types to be
 ;;; unparsed as FUNCTION. This is useful when we want a type that we
@@ -194,7 +196,7 @@
 (defvar *unparse-function-type-simplify*)
 (!cold-init-forms (setq *unparse-function-type-simplify* nil))
 
-(define-type-method (function :unparse) (type)
+(!define-type-method (function :unparse) (type)
   (if *unparse-function-type-simplify*
       'function
       (list 'function
@@ -206,34 +208,34 @@
 
 ;;; Since all function types are equivalent to FUNCTION, they are all
 ;;; subtypes of each other.
-(define-type-method (function :simple-subtypep) (type1 type2)
+(!define-type-method (function :simple-subtypep) (type1 type2)
   (declare (ignore type1 type2))
   (values t t))
 
-(define-superclasses function ((function)) !cold-init-forms)
+(!define-superclasses function ((function)) !cold-init-forms)
 
 ;;; The union or intersection of two FUNCTION types is FUNCTION.
-(define-type-method (function :simple-union) (type1 type2)
+(!define-type-method (function :simple-union) (type1 type2)
   (declare (ignore type1 type2))
   (specifier-type 'function))
-(define-type-method (function :simple-intersection) (type1 type2)
+(!define-type-method (function :simple-intersection2) (type1 type2)
   (declare (ignore type1 type2))
-  (values (specifier-type 'function) t))
+  (specifier-type 'function))
 
 ;;; ### Not very real, but good enough for redefining transforms
 ;;; according to type:
-(define-type-method (function :simple-=) (type1 type2)
+(!define-type-method (function :simple-=) (type1 type2)
   (values (equalp type1 type2) t))
 
-(define-type-class constant :inherits values)
+(!define-type-class constant :inherits values)
 
-(define-type-method (constant :unparse) (type)
+(!define-type-method (constant :unparse) (type)
   `(constant-argument ,(type-specifier (constant-type-type type))))
 
-(define-type-method (constant :simple-=) (type1 type2)
+(!define-type-method (constant :simple-=) (type1 type2)
   (type= (constant-type-type type1) (constant-type-type type2)))
 
-(def-type-translator constant-argument (type)
+(!def-type-translator constant-argument (type)
   (make-constant-type :type (specifier-type type)))
 
 ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE
@@ -244,7 +246,7 @@
   (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))
+      (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))
@@ -255,7 +257,8 @@
 	  (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: ~S." kwd lambda-list))
+	    (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)))
@@ -291,7 +294,7 @@
 
     (result)))
 
-(def-type-translator function (&optional (args '*) (result '*))
+(!def-type-translator function (&optional (args '*) (result '*))
   (let ((res (make-function-type
 	      :returns (values-specifier-type result))))
     (if (eq args '*)
@@ -299,7 +302,7 @@
 	(parse-args-types args res))
     res))
 
-(def-type-translator values (&rest values)
+(!def-type-translator values (&rest values)
   (let ((res (make-values-type)))
     (parse-args-types values res)
     res))
@@ -309,10 +312,8 @@
 ;;;; We provide a few special operations that can be meaningfully used
 ;;;; on VALUES types (as well as on any other 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.
-
-;;; MNA: fix-instance-typep-call patch
+;;; 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)
@@ -320,7 +321,8 @@
   (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)))
+                 (type-union (car (args-type-optional type))
+			     (specifier-type 'null)))
 	     (args-type-rest type)
              (specifier-type 'null)))
 	((eq type *wild-type*)
@@ -342,10 +344,10 @@
 	    (values fixed (+ fixed (length (args-type-optional type))))))
       (values nil nil)))
 
-;;; Determine if Type corresponds to a definite number of values. The
-;;; first value is a list of the types for each value, and the second
-;;; value is the number of values. If the number of values is not
-;;; fixed, then return NIL and :Unknown.
+;;; Determine whether TYPE corresponds to a definite number of values.
+;;; The first value is a list of the types for each value, and the
+;;; second value is the number of values. If the number of values is
+;;; not fixed, then return NIL and :UNKNOWN.
 (defun values-types (type)
   (declare (type ctype type))
   (cond ((eq type *wild-type*)
@@ -362,7 +364,6 @@
 	   (values (mapcar #'single-value-type req) (length req))))))
 
 ;;; Return two values:
-;;; MNA: fix-instance-typep-call patch
 ;;; 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.
@@ -373,8 +374,7 @@
 	  (cond ((args-type-keyp type) *universal-type*)
 		((args-type-rest type))
 		(t
-                  ;; MNA: fix-instance-typep-call patch
-                  default-type))))
+		 default-type))))
 
 ;;; Return a list of OPERATION applied to the types in TYPES1 and
 ;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
@@ -426,19 +426,15 @@
 ;;; 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.
-;;; MNA: fix-instance-typep-call patch
 (defun args-type-op (type1 type2 operation nreq default-type)
-  ;;; MNA: fix-instance-typep-call patch
   (declare (type ctype type1 type2 default-type)
  	   (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)
-            ;;; MNA: fix-instance-typep-call patch
             (values-type-types type1 default-type)
 	  (multiple-value-bind (types2 rest2)
-              ;;; MNA: fix-instance-typep-call patch
               (values-type-types type2 default-type)
 	    (multiple-value-bind (rest rest-exact)
 		(funcall operation rest1 rest2)
@@ -460,7 +456,6 @@
 			       :optional (if opt-last
 					     (subseq opt 0 (1+ opt-last))
 					     ())
-                               ;; MNA fix-instance-typep-call patch
 			       :rest (if (eq rest default-type) nil rest))
 			      (and rest-exact res-exact)))))))))
       (funcall operation type1 type2)))
@@ -482,9 +477,7 @@
 	((eq type1 *empty-type*) type2)
 	((eq type2 *empty-type*) type1)
 	(t
-          ;;; MNA: fix-instance-typep-call patch
 	 (values (args-type-op type1 type2 #'type-union #'min *empty-type*)))))
-;;;
 (defun-cached (values-type-intersection :hash-function type-cache-hash
 					:hash-bits 8
 					:values 2
@@ -495,7 +488,10 @@
   (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)))))
+	 (args-type-op type1 type2
+		       #'type-intersection
+		       #'max
+		       (specifier-type 'null)))))
 
 ;;; This is like TYPES-INTERSECT, except that it sort of works on
 ;;; VALUES types. Note that due to the semantics of
@@ -573,9 +569,9 @@
 	     (eq type2 *empty-type*))
 	 (values nil t))
 	(t
-	 (invoke-type-method :simple-subtypep :complex-subtypep-arg2
-			     type1 type2
-			     :complex-arg1 :complex-subtypep-arg1))))
+	 (!invoke-type-method :simple-subtypep :complex-subtypep-arg2
+			      type1 type2
+			      :complex-arg1 :complex-subtypep-arg1))))
 
 ;;; Just parse the type specifiers and call CSUBTYPE.
 (defun sb!xc:subtypep (type1 type2)
@@ -598,7 +594,7 @@
   (declare (type ctype type1 type2))
   (if (eq type1 type2)
       (values t t)
-      (invoke-type-method :simple-= :complex-= type1 type2)))
+      (!invoke-type-method :simple-= :complex-= type1 type2)))
 
 ;;; Not exactly the negation of TYPE=, since when the relationship is
 ;;; uncertain, we still return NIL, NIL. This is useful in cases where
@@ -622,50 +618,98 @@
   (declare (type ctype type1 type2))
   (if (eq type1 type2)
       type1
-      (let ((res (invoke-type-method :simple-union :complex-union
-				     type1 type2
-				     :default :vanilla)))
+      (let ((res (!invoke-type-method :simple-union :complex-union
+				      type1 type2
+				      :default :vanilla)))
 	(cond ((eq res :vanilla)
 	       (or (vanilla-union type1 type2)
-		   (make-union-type (list type1 type2))))
+		   (make-union-type-or-something (list type1 type2))))
 	      (res)
 	      (t
-	       (make-union-type (list type1 type2)))))))
-
-;;; Return as restrictive a type as we can discover that is no more
-;;; restrictive than the intersection of Type1 and Type2. The second
-;;; value is true if the result is exact. At worst, we randomly return
-;;; one of the arguments as the first value (trying not to return a
-;;; hairy type).
-(defun-cached (type-intersection :hash-function type-cache-hash
-				 :hash-bits 8
-				 :values 2
-				 :default (values nil :empty)
-				 :init-wrapper !cold-init-forms)
+	       (make-union-type-or-something (list type1 type2)))))))
+
+;;; the type method dispatch case of TYPE-INTERSECTION2
+(defun %type-intersection2 (type1 type2)
+  ;; We want to give both argument orders a chance at
+  ;; COMPLEX-INTERSECTION2. Without that, the old CMU CL type
+  ;; methods could give noncommutative results, e.g.
+  ;;   (TYPE-INTERSECTION2 *EMPTY-TYPE* SOME-HAIRY-TYPE)
+  ;;     => NIL, NIL
+  ;;   (TYPE-INTERSECTION2 SOME-HAIRY-TYPE *EMPTY-TYPE*)
+  ;;     => #<NAMED-TYPE NIL>, T
+  ;; We also need to distinguish between the case where we found a
+  ;; type method, and it returned NIL, and the case where we fell
+  ;; through without finding any type method. An example of the first
+  ;; case is the intersection of a HAIRY-TYPE with some ordinary type.
+  ;; An example of the second case is the intersection of two
+  ;; completely-unrelated types, e.g. CONS and NUMBER, or SYMBOL and
+  ;; ARRAY.
+  ;;
+  ;; (Why yes, CLOS probably *would* be nicer..)
+  (flet ((1way (x y)
+	   (!invoke-type-method :simple-intersection2 :complex-intersection2
+				x y
+				:default :no-type-method-found)))
+    (declare (inline 1way))
+    (let ((xy (1way type1 type2)))
+      (or (and (not (eql xy :no-type-method-found)) 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))
+		       *empty-type*)
+		      (t
+		       (assert (and (not xy) (not yx))) ; else handled above
+		       nil))))))))
+
+(defun-cached (type-intersection2 :hash-function type-cache-hash
+				  :hash-bits 8
+				  :values 1
+				  :default nil
+				  :init-wrapper !cold-init-forms)
 	      ((type1 eq) (type2 eq))
   (declare (type ctype type1 type2))
-  (if (eq type1 type2)
-      (values type1 t)
-      (invoke-type-method :simple-intersection :complex-intersection
-			  type1 type2
-			  :default (values *empty-type* t))))
+  (cond ((eq type1 type2)
+	 type1)
+	((or (intersection-type-p type1)
+	     (intersection-type-p type2))
+	 ;; Intersections of INTERSECTION-TYPE should have the
+	 ;; INTERSECTION-TYPE-TYPES objects broken out and intersected
+	 ;; separately. The full TYPE-INTERSECTION function knows how
+	 ;; to do that, so let it handle it.
+	 (type-intersection type1 type2))
+	(t
+	 ;; the ordinary case: we dispatch to type methods
+	 (%type-intersection2 type1 type2))))
+
+;;; Return as restrictive and simple a type as we can discover that is
+;;; no more restrictive than the intersection of TYPE1 and TYPE2. At
+;;; worst, we arbitrarily return one of the arguments as the first
+;;; value (trying not to return a hairy type).
+(defun type-approx-intersection2 (type1 type2)
+  (cond ((type-intersection2 type1 type2))
+	((hairy-type-p type1) type2)
+	(t type1)))
 
 ;;; The first value is true unless the types don't intersect. The
 ;;; second value is true if the first value is definitely correct. NIL
 ;;; is considered to intersect with any type. If T is a subtype of
-;;; either type, then we also return T, T. This way we consider hairy
-;;; types to intersect with T.
+;;; either type, then we also return T, T. This way we recognize
+;;; that hairy types might intersect with T.
+;;;
+;;; FIXME: It would be more accurate to call this TYPES-MIGHT-INTERSECT,
+;;; and rename VALUES-TYPES-INTERSECT the same way.
 (defun types-intersect (type1 type2)
   (declare (type ctype type1 type2))
   (if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
       (values t t)
-      (multiple-value-bind (val winp) (type-intersection type1 type2)
-	(cond ((not winp)
+      (let ((intersection2 (type-intersection2 type1 type2)))
+	(cond ((not intersection2)
 	       (if (or (csubtypep *universal-type* type1)
 		       (csubtypep *universal-type* type2))
 		   (values t t)
 		   (values t nil)))
-	      ((eq val *empty-type*) (values nil t))
+	      ((eq intersection2 *empty-type*) (values nil t))
 	      (t (values t t))))))
 
 ;;; Return a Common Lisp type specifier corresponding to the TYPE
@@ -677,8 +721,8 @@
 ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
 ;;; early-type.lisp by WHN ca. 19990201.)
 
-;;; Take a list of type specifiers, compute the translation and define
-;;; it as a builtin type.
+;;; Take a list of type specifiers, computing the translation of each
+;;; specifier and defining it as a builtin type.
 (declaim (ftype (function (list) (values)) precompute-types))
 (defun precompute-types (specs)
   (dolist (spec specs)
@@ -688,9 +732,75 @@
 	(setf (info :type :kind spec) :primitive))))
   (values))
 
+;;;; general TYPE-UNION and TYPE-INTERSECTION operations
+;;;;
+;;;; 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 and replacing them by their simplified forms.
+(defun accumulate-compound-type (type types simplify2)
+  (declare (type ctype type))
+  (declare (type (vector t) types))
+  (declare (type function simplify2))
+  (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))
+	;; Add the new SIMPLIFIED2 to TYPES, by tail recursing.
+	(return (accumulate-compound-type simplified2
+					  types
+					  simplify2)))))
+  (values))
+
+;;; 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-VECTOR is short.
+(defun make-compound-type-or-something (constructor types enumerable identity)
+  (declare (type function constructor))
+  (declare (type (vector t) types))
+  (declare (type ctype identity))
+  (case (length types)
+    (0 identity)
+    (1 (the ctype (aref types 0)))
+    (t (funcall constructor enumerable (coerce types 'list)))))
+
+(defun type-intersection (&rest input-types)
+  (let (;; components of our result, accumulated as a vector
+	(simplified-types (make-array (length input-types) :fill-pointer 0)))
+    (flet ((accumulate (type)
+	     (accumulate-compound-type type
+				       simplified-types
+				       #'type-intersection2)))
+      (declare (inline accumulate))
+      (dolist (type input-types)
+	(if (intersection-type-p type)
+	    (map nil #'accumulate (intersection-type-types type))
+	    (accumulate type)))
+      ;; We want to have a canonical representation of types (or failing
+      ;; that, punt to HAIRY-TYPE). Canonical representation would have
+      ;; intersections inside unions but not vice versa, since you can
+      ;; always achieve that by the distributive rule. But we don't want
+      ;; to just apply the distributive rule, since it would be too easy
+      ;; to end up with unreasonably huge type expressions. So instead
+      ;; we punt to HAIRY-TYPE when this comes up.
+      (if (and (> (length simplified-types) 1)
+	       (some #'union-type-p simplified-types))
+	  (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*)))))
+
+;;; FIXME: Define TYPE-UNION similar to TYPE-INTERSECTION.
+
 ;;;; built-in types
 
-(define-type-class named)
+(!define-type-class named)
 
 (defvar *wild-type*)
 (defvar *empty-type*)
@@ -712,32 +822,59 @@
    (frob nil *empty-type*)
    (frob t *universal-type*)))
 
-(define-type-method (named :simple-=) (type1 type2)
+(!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.
+  ;;(assert (not (eq type1 *wild-type*))) ; * isn't really a type.
   (values (eq type1 type2) t))
 
-(define-type-method (named :simple-subtypep) (type1 type2)
+(!define-type-method (named :simple-subtypep) (type1 type2)
+  (assert (not (eq type1 *wild-type*))) ; * isn't really a type.
   (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
 
-(define-type-method (named :complex-subtypep-arg1) (type1 type2)
-  (assert (not (hairy-type-p type2)))
+(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
+  (assert (not (eq type1 *wild-type*))) ; * isn't really a type.
+  ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause
+  ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over
+  ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..)
+  (assert (not (hairy-type-p type2))) 
+  ;; Besides the old CMU CL assertion above, we also need to avoid
+  ;; compound types, else we could get into trouble with
+  ;;   (SUBTYPEP 'T '(OR (SATISFIES FOO) (SATISFIES BAR)))
+  ;; or
+  ;;   (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))).
+  (assert (not (compound-type-p type2))) 
+  ;; Then, since TYPE2 is reasonably tractable, we're good to go.
   (values (eq type1 *empty-type*) t))
 
-(define-type-method (named :complex-subtypep-arg2) (type1 type2)
-  (if (hairy-type-p type1)
-      (values nil nil)
-      (values (not (eq type2 *empty-type*)) t)))
-
-(define-type-method (named :complex-intersection) (type1 type2)
-  (vanilla-intersection type1 type2))
-
-(define-type-method (named :unparse) (x)
+(!define-type-method (named :complex-subtypep-arg2) (type1 type2)
+  (assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+  (cond ((eq type2 *universal-type*)
+	 (values t t))
+	((hairy-type-p type1)
+	 (values nil nil))
+	(t
+	 ;; FIXME: This seems to rely on there only being 2 or 3
+	 ;; HAIRY-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))))
+
+(!define-type-method (named :complex-intersection2) (type1 type2)
+  ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
+  ;; Perhaps when bug 85 is fixed it can be reenabled.
+  ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+  (hierarchical-intersection2 type1 type2))
+
+(!define-type-method (named :unparse) (x)
   (named-type-name x))
 
 ;;;; 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)
+(!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)
@@ -749,53 +886,60 @@
 	  (t
 	   (values nil nil)))))
 
-(define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
+(!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))
-	   (multiple-value-bind (val win)
-	       (type-intersection type1 (specifier-type (cadr hairy-spec)))
-	     (if win
-		 (values (eq val *empty-type*) t)
+	   (let* ((complement-type2 (specifier-type (cadr hairy-spec)))
+		  (intersection2 (type-intersection2 type1
+						     complement-type2)))
+	     (if intersection2
+		 (values (eq intersection2 *empty-type*) t)
 		 (values nil nil))))
 	  (t
 	   (values nil nil)))))
 
-(define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
+(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
   (declare (ignore type1 type2))
   (values nil nil))
 
-(define-type-method (hairy :simple-intersection :complex-intersection)
-		    (type1 type2)
-  (declare (ignore type2))
-  (values type1 nil))
+(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
+		     (type1 type2)
+  (declare (ignore type1 type2))
+  nil)
 
-(define-type-method (hairy :complex-union) (type1 type2)
-  (make-union-type (list type1 type2)))
+(!define-type-method (hairy :complex-union) (type1 type2)
+  (make-union-type-or-something (list type1 type2)))
 
-(define-type-method (hairy :simple-=) (type1 type2)
+(!define-type-method (hairy :simple-=) (type1 type2)
   (if (equal (hairy-type-specifier type1)
 	     (hairy-type-specifier type2))
       (values t t)
       (values nil nil)))
 
-(def-type-translator not (&whole whole type)
+(!def-type-translator not (&whole whole type)
   (declare (ignore type))
+  ;; Check legality of arguments.
+  (destructuring-bind (not typespec) whole
+    (declare (ignore not))
+    (specifier-type typespec)) ; must be legal typespec
+  ;; Create object.
   (make-hairy-type :specifier whole))
 
-(def-type-translator satisfies (&whole whole fun)
+(!def-type-translator satisfies (&whole whole fun)
   (declare (ignore fun))
+  ;; Check legality of arguments of arguments.
+  (destructuring-bind (satisfies predicate-name) whole
+    (declare (ignore satisfies))
+    (unless (symbolp predicate-name)
+      (error 'simple-type-error
+	     :datum predicate-name
+	     :expected-type symbol
+	     :format-control "~S is not a symbol."
+	     :format-arguments (list predicate-name))))
   (make-hairy-type :specifier whole))
 
 ;;;; numeric types
 
-;;; A list of all the float formats, in order of decreasing precision.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defparameter *float-formats*
-    '(long-float double-float single-float short-float)))
-
-;;; The type of a float format.
-(deftype float-format () `(member ,@*float-formats*))
-
 #!+negative-zero-is-not-zero
 (defun make-numeric-type (&key class format (complexp :real) low high
 			       enumerable)
@@ -818,9 +962,9 @@
 			:high (canonicalise-high-bound high)
 			:enumerable enumerable)))
 
-(define-type-class number)
+(!define-type-class number)
 
-(define-type-method (number :simple-=) (type1 type2)
+(!define-type-method (number :simple-=) (type1 type2)
   (values
    (and (eq (numeric-type-class type1) (numeric-type-class type2))
 	(eq (numeric-type-format type1) (numeric-type-format type2))
@@ -829,7 +973,7 @@
 	(equal (numeric-type-high type1) (numeric-type-high type2)))
    t))
 
-(define-type-method (number :unparse) (type)
+(!define-type-method (number :unparse) (type)
   (let* ((complexp (numeric-type-complexp type))
 	 (low (numeric-type-low type))
 	 (high (numeric-type-high type))
@@ -969,7 +1113,7 @@
 		(if (,open (car ,n-y) ,n-x) ,n-y ,n-x)
 		(if (,closed ,n-y ,n-x) ,n-y ,n-x))))))
 
-(define-type-method (number :simple-subtypep) (type1 type2)
+(!define-type-method (number :simple-subtypep) (type1 type2)
   (let ((class1 (numeric-type-class type1))
 	(class2 (numeric-type-class type2))
 	(complexp2 (numeric-type-complexp type2))
@@ -1001,7 +1145,7 @@
 	  (t
 	   (values nil t)))))
 
-(define-superclasses number ((generic-number)) !cold-init-forms)
+(!define-superclasses number ((generic-number)) !cold-init-forms)
 
 ;;; If the high bound of LOW is adjacent to the low bound of HIGH,
 ;;; then return true, otherwise NIL.
@@ -1041,9 +1185,9 @@
 
 ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
 ;;;
-;;; ### Note: we give up early, so keep from dropping lots of information on
+;;; ### 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-union) (type1 type2)
+(!define-type-method (number :simple-union) (type1 type2)
   (declare (type numeric-type type1 type2))
   (cond ((csubtypep type1 type2) type2)
 	((csubtypep type2 type1) type1)
@@ -1076,7 +1220,7 @@
   (setf (info :type :builtin 'number)
 	(make-numeric-type :complexp nil)))
 
-(def-type-translator complex (&optional (spec '*))
+(!def-type-translator complex (&optional (spec '*))
   (if (eq spec '*)
       (make-numeric-type :complexp :complex)
       (let ((type (specifier-type spec)))
@@ -1105,7 +1249,7 @@
 		type
 		bound))))
 
-(def-type-translator integer (&optional (low '*) (high '*))
+(!def-type-translator integer (&optional (low '*) (high '*))
   (let* ((l (canonicalized-bound low 'integer))
 	 (lb (if (consp l) (1+ (car l)) l))
 	 (h (canonicalized-bound high 'integer))
@@ -1118,25 +1262,25 @@
 		       :low lb
 		       :high hb)))
 
-(defmacro def-bounded-type (type class format)
-  `(def-type-translator ,type (&optional (low '*) (high '*))
+(defmacro !def-bounded-type (type class format)
+  `(!def-type-translator ,type (&optional (low '*) (high '*))
      (let ((lb (canonicalized-bound low ',type))
 	   (hb (canonicalized-bound high ',type)))
        (unless (numeric-bound-test* lb hb <= <)
 	 (error "Lower bound ~S is not less than upper bound ~S." low high))
        (make-numeric-type :class ',class :format ',format :low lb :high hb))))
 
-(def-bounded-type rational rational nil)
-(def-bounded-type float float nil)
-(def-bounded-type real nil nil)
+(!def-bounded-type rational rational nil)
+(!def-bounded-type float float nil)
+(!def-bounded-type real nil nil)
 
-(defmacro define-float-format (f)
-  `(def-bounded-type ,f float ,f))
+(defmacro !define-float-format (f)
+  `(!def-bounded-type ,f float ,f))
 
-(define-float-format short-float)
-(define-float-format single-float)
-(define-float-format double-float)
-(define-float-format long-float)
+(!define-float-format short-float)
+(!define-float-format single-float)
+(!define-float-format double-float)
+(!define-float-format long-float)
 
 (defun numeric-types-intersect (type1 type2)
   (declare (type numeric-type type1 type2))
@@ -1213,7 +1357,7 @@
 	     (if (consp x) (list res) res)))))
       nil))
 
-;;; Handle the case of TYPE-INTERSECTION on two numeric types. We use
+;;; Handle the case of type intersection on two numeric types. We use
 ;;; TYPES-INTERSECT to throw out the case of types with no
 ;;; intersection. If an attribute in TYPE1 is unspecified, then we use
 ;;; TYPE2's attribute, which must be at least as restrictive. If the
@@ -1229,7 +1373,7 @@
 ;;; appropriate numeric type before maximizing. This avoids possible
 ;;; confusion due to mixed-type comparisons (but I think the result is
 ;;; the same).
-(define-type-method (number :simple-intersection) (type1 type2)
+(!define-type-method (number :simple-intersection2) (type1 type2)
   (declare (type numeric-type type1 type2))
   (if (numeric-types-intersect type1 type2)
       (let* ((class1 (numeric-type-class type1))
@@ -1242,26 +1386,24 @@
 				       'rational))))
 	     (format (or (numeric-type-format type1)
 			 (numeric-type-format type2))))
-	(values
-	 (make-numeric-type
-	  :class class
-	  :format format
-	  :complexp (or (numeric-type-complexp type1)
-			(numeric-type-complexp type2))
-	  :low (numeric-bound-max
-		(round-numeric-bound (numeric-type-low type1)
-				     class format t)
-		(round-numeric-bound (numeric-type-low type2)
-				     class format t)
-		> >= nil)
-	  :high (numeric-bound-max
-		 (round-numeric-bound (numeric-type-high type1)
-				      class format nil)
-		 (round-numeric-bound (numeric-type-high type2)
-				      class format nil)
-		 < <= nil))
-	 t))
-      (values *empty-type* t)))
+	(make-numeric-type
+	 :class class
+	 :format format
+	 :complexp (or (numeric-type-complexp type1)
+		       (numeric-type-complexp type2))
+	 :low (numeric-bound-max
+	       (round-numeric-bound (numeric-type-low type1)
+				    class format t)
+	       (round-numeric-bound (numeric-type-low type2)
+				    class format t)
+	       > >= nil)
+	 :high (numeric-bound-max
+		(round-numeric-bound (numeric-type-high type1)
+				     class format nil)
+		(round-numeric-bound (numeric-type-high type2)
+				     class format nil)
+		< <= nil)))
+      *empty-type*))
 
 ;;; Given two float formats, return the one with more precision. If
 ;;; either one is null, return NIL.
@@ -1325,7 +1467,7 @@
 
 ;;;; array types
 
-(define-type-class array)
+(!define-type-class array)
 
 ;;; What this does depends on the setting of the
 ;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized
@@ -1336,7 +1478,7 @@
       (array-type-specialized-element-type type)
       (array-type-element-type type)))
 
-(define-type-method (array :simple-=) (type1 type2)
+(!define-type-method (array :simple-=) (type1 type2)
   (values (and (equal (array-type-dimensions type1)
 		      (array-type-dimensions type2))
 	       (eq (array-type-complexp type1)
@@ -1345,7 +1487,7 @@
 		      (specialized-element-type-maybe type2)))
 	  t))
 
-(define-type-method (array :unparse) (type)
+(!define-type-method (array :unparse) (type)
   (let ((dims (array-type-dimensions type))
 	(eltype (type-specifier (array-type-element-type type)))
 	(complexp (array-type-complexp type)))
@@ -1385,12 +1527,12 @@
 	       `(array ,eltype ,dims)
 	       `(simple-array ,eltype ,dims))))))
 
-(define-type-method (array :simple-subtypep) (type1 type2)
+(!define-type-method (array :simple-subtypep) (type1 type2)
   (let ((dims1 (array-type-dimensions type1))
 	(dims2 (array-type-dimensions type2))
 	(complexp2 (array-type-complexp type2)))
-    ;; See whether dimensions are compatible.
-    (cond ((not (or (eq dims2 '*)
+    (cond (;; not subtypep unless dimensions are compatible
+	   (not (or (eq dims2 '*)
 		    (and (not (eq dims1 '*))
 			 ;; (sbcl-0.6.4 has trouble figuring out that
 			 ;; DIMS1 and DIMS2 must be lists at this
@@ -1403,20 +1545,29 @@
 				(the list dims1)
 				(the list dims2)))))
 	   (values nil t))
-	  ;; See whether complexpness is compatible.
+	  ;; not subtypep unless complexness is compatible
 	  ((not (or (eq complexp2 :maybe)
 		    (eq (array-type-complexp type1) complexp2)))
 	   (values nil t))
-	  ;; If the TYPE2 eltype is wild, we win. Otherwise, the types
-	  ;; must be identical.
-	  ((or (eq (array-type-element-type type2) *wild-type*)
-	       (type= (specialized-element-type-maybe type1)
-		      (specialized-element-type-maybe type2)))
+	  ;; Since we didn't fail any of the tests above, we win
+	  ;; if the TYPE2 element type is wild.
+	  ((eq (array-type-element-type type2) *wild-type*)
 	   (values t t))
-	  (t
-	   (values nil t)))))
-
-(define-superclasses array
+	  (;; Since we didn't match any of the special cases above, we
+	   ;; can't give a good answer unless both the element types
+	   ;; have been defined.
+	   (or (unknown-type-p (array-type-element-type type1))
+	       (unknown-type-p (array-type-element-type type2)))
+	   (values nil nil))
+	  (;; Otherwise, the subtype relationship holds iff the
+	   ;; types are equal, and they're equal iff the specialized
+	   ;; element types are identical.
+	   t
+	   (values (type= (specialized-element-type-maybe type1)
+			  (specialized-element-type-maybe type2))
+		   t)))))
+
+(!define-superclasses array
   ((string string)
    (vector vector)
    (array))
@@ -1451,7 +1602,7 @@
 	  (t
 	   (values nil t)))))
 
-(define-type-method (array :simple-intersection) (type1 type2)
+(!define-type-method (array :simple-intersection2) (type1 type2)
   (declare (type array-type type1 type2))
   (if (array-types-intersect type1 type2)
       (let ((dims1 (array-type-dimensions type1))
@@ -1460,18 +1611,16 @@
 	    (complexp2 (array-type-complexp type2))
 	    (eltype1 (array-type-element-type type1))
 	    (eltype2 (array-type-element-type type2)))
-	(values
-	 (specialize-array-type
-	  (make-array-type
-	   :dimensions (cond ((eq dims1 '*) dims2)
-			     ((eq dims2 '*) dims1)
-			     (t
-			      (mapcar (lambda (x y) (if (eq x '*) y x))
-				      dims1 dims2)))
-	   :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
-	   :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1)))
-	 t))
-      (values *empty-type* t)))
+	(specialize-array-type
+	 (make-array-type
+	  :dimensions (cond ((eq dims1 '*) dims2)
+			    ((eq dims2 '*) dims1)
+			    (t
+			     (mapcar (lambda (x y) (if (eq x '*) y x))
+				     dims1 dims2)))
+	  :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
+	  :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1))))
+      *empty-type*))
 
 ;;; Check a supplied dimension list to determine whether it is legal,
 ;;; and return it in canonical form (as either '* or a list).
@@ -1499,65 +1648,60 @@
 
 ;;;; MEMBER types
 
-(define-type-class member)
+(!define-type-class member)
 
-(define-type-method (member :unparse) (type)
+(!define-type-method (member :unparse) (type)
   (let ((members (member-type-members type)))
     (if (equal members '(nil))
 	'null
 	`(member ,@members))))
 
-(define-type-method (member :simple-subtypep) (type1 type2)
+(!define-type-method (member :simple-subtypep) (type1 type2)
   (values (subsetp (member-type-members type1) (member-type-members type2))
 	  t))
 
-(define-type-method (member :complex-subtypep-arg1) (type1 type2)
-  (block PUNT
-    (values (every-type-op ctypep type2 (member-type-members type1)
-			   :list-first t)
-	    t)))
+(!define-type-method (member :complex-subtypep-arg1) (type1 type2)
+  (every/type (swapped-args-fun #'ctypep)
+	      type2
+	      (member-type-members type1)))
 
 ;;; We punt if the odd type is enumerable and intersects with the
 ;;; MEMBER type. If not enumerable, then it is definitely not a
 ;;; subtype of the MEMBER type.
-(define-type-method (member :complex-subtypep-arg2) (type1 type2)
+(!define-type-method (member :complex-subtypep-arg2) (type1 type2)
   (cond ((not (type-enumerable type1)) (values nil t))
 	((types-intersect type1 type2) (values nil nil))
-	(t
-	 (values nil t))))
+	(t (values nil t))))
 
-(define-type-method (member :simple-intersection) (type1 type2)
+(!define-type-method (member :simple-intersection2) (type1 type2)
   (let ((mem1 (member-type-members type1))
 	(mem2 (member-type-members type2)))
-    (values (cond ((subsetp mem1 mem2) type1)
-		  ((subsetp mem2 mem1) type2)
-		  (t
-		   (let ((res (intersection mem1 mem2)))
-		     (if res
-			 (make-member-type :members res)
-			 *empty-type*))))
-	    t)))
+    (cond ((subsetp mem1 mem2) type1)
+	  ((subsetp mem2 mem1) type2)
+	  (t
+	   (let ((res (intersection mem1 mem2)))
+	     (if res
+		 (make-member-type :members res)
+		 *empty-type*))))))
 
-(define-type-method (member :complex-intersection) (type1 type2)
-  (block PUNT
+(!define-type-method (member :complex-intersection2) (type1 type2)
+  (block punt		     
     (collect ((members))
       (let ((mem2 (member-type-members type2)))
-	(dolist (member mem2)
+        (dolist (member mem2)
 	  (multiple-value-bind (val win) (ctypep member type1)
 	    (unless win
-	      (return-from PUNT (values type2 nil)))
+	      (return-from punt nil))
 	    (when val (members member))))
+	(cond ((subsetp mem2 (members)) type2)
+	      ((null (members)) *empty-type*)
+	      (t
+	       (make-member-type :members (members))))))))
 
-	(values (cond ((subsetp mem2 (members)) type2)
-		      ((null (members)) *empty-type*)
-		      (t
-		       (make-member-type :members (members))))
-		t)))))
-
-;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union
-;;; type, and the member/union interaction is handled by the union type
-;;; method.
-(define-type-method (member :simple-union) (type1 type2)
+;;; We don't need a :COMPLEX-UNION, since the only interesting case is
+;;; a union type, and the member/union interaction is handled by the
+;;; union type method.
+(!define-type-method (member :simple-union) (type1 type2)
   (let ((mem1 (member-type-members type1))
 	(mem2 (member-type-members type2)))
     (cond ((subsetp mem1 mem2) type2)
@@ -1565,13 +1709,14 @@
 	  (t
 	   (make-member-type :members (union mem1 mem2))))))
 
-(define-type-method (member :simple-=) (type1 type2)
+(!define-type-method (member :simple-=) (type1 type2)
   (let ((mem1 (member-type-members type1))
 	(mem2 (member-type-members type2)))
-    (values (and (subsetp mem1 mem2) (subsetp mem2 mem1))
+    (values (and (subsetp mem1 mem2)
+		 (subsetp mem2 mem1))
 	    t)))
 
-(define-type-method (member :complex-=) (type1 type2)
+(!define-type-method (member :complex-=) (type1 type2)
   (if (type-enumerable type1)
       (multiple-value-bind (val win) (csubtypep type2 type1)
 	(if (or val (not win))
@@ -1579,69 +1724,150 @@
 	    (values nil t)))
       (values nil t)))
 
-(def-type-translator member (&rest members)
+(!def-type-translator member (&rest members)
   (if members
     (make-member-type :members (remove-duplicates members))
     *empty-type*))
 
+;;;; intersection types
+;;;;
+;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach
+;;;; of punting on all AND types, not just the unreasonably complicated
+;;;; ones. The change was motivated by trying to get the KEYWORD type
+;;;; to behave sensibly:
+;;;;    ;; reasonable definition
+;;;;    (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP)))
+;;;;    ;; reasonable behavior
+;;;;    (ASSERT (SUBTYPEP 'KEYWORD 'SYMBOL))
+;;;; Without understanding a little about the semantics of AND, we'd
+;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely
+;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's
+;;;; not so good..)
+;;;;
+;;;; We still follow the example of CMU CL to some extent, by punting
+;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
+;;;; involving AND.
+
+(!define-type-class intersection)
+
+;;; A few intersection types have special names. The others just get
+;;; mechanically unparsed.
+(!define-type-method (intersection :unparse) (type)
+  (declare (type ctype type))
+  (or (find type '(ratio bignum 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)
+	   (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)))
+
+;;; Two intersection types are equal if their subtypes are equal sets.
+;;;
+;;; FIXME: Might it be better to use
+;;;   (AND (SUBTYPEP X Y) (SUBTYPEP Y X))
+;;; instead, since SUBTYPEP is the usual relationship that we care
+;;; most about, so it would be good to leverage any ingenuity there
+;;; in this more obscure method?
+(!define-type-method (intersection :simple-=) (type1 type2)
+  (type=-set (intersection-type-types type1)
+	     (intersection-type-types type2)))
+
+(flet ((intersection-complex-subtypep-arg1 (type1 type2)
+         (any/type (swapped-args-fun #'csubtypep)
+		   type2
+		   (intersection-type-types type1))))
+  (!define-type-method (intersection :simple-subtypep) (type1 type2)
+    (every/type #'intersection-complex-subtypep-arg1
+		type1
+		(intersection-type-types 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)
+  (every/type #'csubtypep type1 (intersection-type-types type2)))
+
+(!def-type-translator and (&whole whole &rest type-specifiers)
+  (apply #'type-intersection
+	 (mapcar #'specifier-type
+		 type-specifiers)))
+
 ;;;; union types
 
 ;;; Make a union type from the specifier types, setting ENUMERABLE in
-;;; the result if all are enumerable.
-(defun make-union-type (types)
+;;; the result if all are enumerable; or take the easy way out if we
+;;; recognize a special case which can be represented more simply.
+(defun make-union-type-or-something (types)
   (declare (list types))
-  (%make-union-type (every #'type-enumerable types) types))
+  (cond ((null types)
+	 *empty-type*)
+	((null (cdr types))
+	 (first types))
+	(t
+	 (%make-union-type (every #'type-enumerable types) types))))
 
-(define-type-class union)
+(!define-type-class union)
 
-;;; If LIST, then return that, otherwise the OR of the component types.
-(define-type-method (union :unparse) (type)
+;;; The LIST type has a special name. 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)))))
 
-;;; Two union types are equal if every type in one is equal to some
-;;; type in the other.
-(define-type-method (union :simple-=) (type1 type2)
-  (block PUNT
-    (let ((types1 (union-type-types type1))
-	  (types2 (union-type-types type2)))
-      (values (and (dolist (type1 types1 t)
-		     (unless (any-type-op type= type1 types2)
-		       (return nil)))
-		   (dolist (type2 types2 t)
-		     (unless (any-type-op type= type2 types1)
-		       (return nil))))
-	      t))))
+;;; Two union types are equal if their subtypes are equal sets.
+(!define-type-method (union :simple-=) (type1 type2)
+  (type=-set (union-type-types type1)
+	     (union-type-types type2)))
 
 ;;; Similarly, a union type is a subtype of another if every element
 ;;; of TYPE1 is a subtype of some element of TYPE2.
-(define-type-method (union :simple-subtypep) (type1 type2)
-  (block PUNT
-    (let ((types2 (union-type-types type2)))
-      (values (dolist (type1 (union-type-types type1) t)
-		(unless (any-type-op csubtypep type1 types2)
-		  (return nil)))
-	      t))))
-
-(define-type-method (union :complex-subtypep-arg1) (type1 type2)
-  (block PUNT
-    (values (every-type-op csubtypep type2 (union-type-types type1)
-			   :list-first t)
-	    t)))
-
-(define-type-method (union :complex-subtypep-arg2) (type1 type2)
-  (block PUNT
-    (values (any-type-op csubtypep type1 (union-type-types type2)) t)))
-
-(define-type-method (union :complex-union) (type1 type2)
-  (let* ((class1 (type-class-info type1)))
+;;;
+;;; KLUDGE: This definition seems redundant, here in UNION-TYPE and
+;;; similarly in INTERSECTION-TYPE, with the logic in the
+;;; corresponding :COMPLEX-SUBTYPEP-ARG1 and :COMPLEX-SUBTYPEP-ARG2
+;;; methods. Ideally there's probably some way to make the
+;;; :SIMPLE-SUBTYPEP method default to the :COMPLEX-SUBTYPEP-FOO
+;;; methods in such a way that this definition could go away, but I
+;;; don't grok the system well enough to tell whether it's simple to
+;;; arrange this. -- WHN 2000-02-03
+(!define-type-method (union :simple-subtypep) (type1 type2)
+  (dolist (t1 (union-type-types type1) (values t t))
+    (multiple-value-bind (subtypep validp)
+	(union-complex-subtypep-arg2 t1 type2)
+      (cond ((not validp)
+	     (return (values nil nil)))
+	    ((not subtypep)
+	     (return (values nil t)))))))
+
+(defun union-complex-subtypep-arg1 (type1 type2)
+  (every/type (swapped-args-fun #'csubtypep)
+	      type2
+	      (union-type-types type1)))
+(!define-type-method (union :complex-subtypep-arg1) (type1 type2)
+  (union-complex-subtypep-arg1 type1 type2))
+
+(defun union-complex-subtypep-arg2 (type1 type2)
+  (any/type #'csubtypep type1 (union-type-types type2)))
+(!define-type-method (union :complex-subtypep-arg2) (type1 type2)
+  (union-complex-subtypep-arg2 type1 type2))
+
+(!define-type-method (union :complex-union) (type1 type2)
+  (let ((class1 (type-class-info type1)))
     (collect ((res))
       (let ((this-type type1))
 	(dolist (type (union-type-types type2)
 		      (if (res)
-			  (make-union-type (cons this-type (res)))
+			  (make-union-type-or-something (cons this-type (res)))
 			  this-type))
 	  (cond ((eq (type-class-info type) class1)
 		 (let ((union (funcall (type-class-simple-union class1)
@@ -1656,37 +1882,99 @@
 
 ;;; For the union of union types, we let the :COMPLEX-UNION method do
 ;;; the work.
-(define-type-method (union :simple-union) (type1 type2)
+(!define-type-method (union :simple-union) (type1 type2)
   (let ((res type1))
     (dolist (t2 (union-type-types type2) res)
       (setq res (type-union res t2)))))
 
-(define-type-method (union :simple-intersection :complex-intersection)
-		    (type1 type2)
-  (let ((res *empty-type*)
-	(win t))
-    (dolist (type (union-type-types type2) (values res win))
-      (multiple-value-bind (int w) (type-intersection type1 type)
-	(setq res (type-union res int))
-	(unless w (setq win nil))))))
-
-(def-type-translator or (&rest types)
+(!define-type-method (union :simple-intersection2 :complex-intersection2)
+ 		     (type1 type2)
+  ;; The CSUBTYPEP clauses here let us simplify e.g.
+  ;;   (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST)
+  ;;                       (SPECIFIER-TYPE '(OR LIST VECTOR)))
+  ;; (where LIST is (OR CONS NULL)).
+  ;;
+  ;; The tests are more or less (CSUBTYPEP TYPE1 TYPE2) and vice
+  ;; versa, but it's important that we pre-expand them into
+  ;; specialized operations on individual elements of
+  ;; UNION-TYPE-TYPES, instead of using the ordinary call to
+  ;; CSUBTYPEP, in order to avoid possibly invoking any methods which
+  ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus
+  ;; cause infinite recursion.
+  (cond ((union-complex-subtypep-arg2 type1 type2)
+	 type1)
+	((union-complex-subtypep-arg1 type2 type1)
+	 type2)
+	(t 
+	 (let (;; a component of TYPE2 whose intersection with TYPE1
+	       ;; is nonempty
+	       (nontriv-t2 nil))
+	   (dolist (t2 (union-type-types type2) (or nontriv-t2 *empty-type*))
+	     (unless (eq *empty-type* (type-intersection type1 t2))
+	       (if nontriv-t2 ; if this is second nonempty intersection
+		   (return nil) ; too many: can't find nice result
+		   (setf nontriv-t2 t2))))))))
+
+(!def-type-translator or (&rest type-specifiers)
   (reduce #'type-union
-	  (mapcar #'specifier-type types)
+	  (mapcar #'specifier-type type-specifiers)
 	  :initial-value *empty-type*))
-
-;;; We don't actually have intersection types, since the result of
-;;; reasonable type intersections is always describable as a union of
-;;; simple types. If something is too hairy to fit this mold, then we
-;;; make a hairy type.
-(def-type-translator and (&whole spec &rest types)
-  (let ((res *wild-type*))
-    (dolist (type types res)
-      (let ((ctype (specifier-type type)))
-	(multiple-value-bind (int win) (type-intersection res ctype)
-	  (unless win
-	    (return (make-hairy-type :specifier spec)))
-	  (setq res int))))))
+
+;;;; CONS types
+
+(!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)))
+ 
+(!define-type-method (cons :unparse) (type)
+  (let ((car-eltype (type-specifier (cons-type-car-type type)))
+	(cdr-eltype (type-specifier (cons-type-cdr-type type))))
+    (if (and (member car-eltype '(t *))
+	     (member cdr-eltype '(t *)))
+	'cons
+	`(cons ,car-eltype ,cdr-eltype))))
+ 
+(!define-type-method (cons :simple-=) (type1 type2)
+  (declare (type cons-type type1 type2))
+  (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
+       (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
+ 
+(!define-type-method (cons :simple-subtypep) (type1 type2)
+  (declare (type cons-type type1 type2))
+  (multiple-value-bind (val-car win-car)
+      (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
+    (multiple-value-bind (val-cdr win-cdr)
+	(csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
+      (if (and val-car val-cdr)
+	  (values t (and win-car win-cdr))
+	  (values nil (or win-car win-cdr))))))
+ 
+;;; Give up if a precise type is not possible, to avoid returning
+;;; overly general types.
+(!define-type-method (cons :simple-union) (type1 type2)
+  (declare (type cons-type type1 type2))
+  (let ((car-type1 (cons-type-car-type type1))
+	(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)))))
+
+(!define-type-method (cons :simple-intersection2) (type1 type2)
+  (declare (type cons-type type1 type2))
+  (let (car-int2
+	cdr-int2)
+    (and (setf car-int2 (type-intersection2 (cons-type-car-type type1)
+					    (cons-type-car-type type2)))
+	 (setf cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
+					    (cons-type-cdr-type type2)))
+	 (make-cons-type car-int2 cdr-int2))))
 
 ;;; Return the type that describes all objects that are in X but not
 ;;; in Y. If we can't determine this type, then return NIL.
@@ -1739,19 +2027,21 @@
       (cond ((null (res)) *empty-type*)
 	    ((null (rest (res))) (first (res)))
 	    (t
-	     (make-union-type (res)))))))
+	     (make-union-type-or-something (res)))))))
 
-(def-type-translator array (&optional (element-type '*)
-				      (dimensions '*))
+(!def-type-translator array (&optional (element-type '*)
+				       (dimensions '*))
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
 		    :element-type (specifier-type element-type))))
 
-(def-type-translator simple-array (&optional (element-type '*)
-					     (dimensions '*))
+(!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)))
 
 (!defun-from-collected-cold-init-forms !late-type-cold-init)
+
+(/show0 "late-type.lisp end of file")