X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=799d6e9cb794c39a2c2fe9b72b4b942fcfcb23c7;hb=bb93c9001110f38e28af43012e2c4bdda871b630;hp=cd1a79693824ff092f6a7f825ee350f93bed3790;hpb=cc420058fedd26d85158b92285bf5a0ea9a826c1;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index cd1a796..799d6e9 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -154,6 +154,9 @@
   (declare (ignore type1))
   (error "SUBTYPEP is illegal on this type:~%  ~S" (type-specifier type2)))
 
+(!define-type-method (values :negate) (type)
+  (error "NOT VALUES too confusing on ~S" (type-specifier type)))
+
 (!define-type-method (values :unparse) (type)
   (cons 'values
         (let ((unparsed (unparse-args-types type)))
@@ -192,6 +195,9 @@
 (defvar *unparse-fun-type-simplify*)
 (!cold-init-forms (setq *unparse-fun-type-simplify* nil))
 
+(!define-type-method (function :negate) (type)
+  (error "NOT FUNCTION too confusing on ~S" (type-specifier type)))
+
 (!define-type-method (function :unparse) (type)
   (if *unparse-fun-type-simplify*
       'function
@@ -318,6 +324,9 @@
 
 (!define-type-class constant :inherits values)
 
+(!define-type-method (constant :negate) (type)
+  (error "NOT CONSTANT too confusing on ~S" (type-specifier type)))
+
 (!define-type-method (constant :unparse) (type)
   `(constant-arg ,(type-specifier (constant-type-type type))))
 
@@ -627,28 +636,28 @@
 
 (defun-cached (values-type-intersection :hash-function type-cache-hash
 					:hash-bits 8
-					:values 2
-					:default (values nil :empty)
+					:default (values nil)
 					:init-wrapper !cold-init-forms)
     ((type1 eq) (type2 eq))
   (declare (type ctype type1 type2))
-  (cond ((eq type1 *wild-type*) (values (coerce-to-values type2) t))
+  (cond ((eq type1 *wild-type*)
+         (coerce-to-values type2))
         ((or (eq type2 *wild-type*) (eq type2 *universal-type*))
-         (values type1 t))
+         type1)
         ((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))))
+           (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
-         (values-type-op type1 (coerce-to-values type2)
-                         #'type-intersection
-                         #'max))))
+         (values (values-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
@@ -660,9 +669,9 @@
         ((or (eq type1 *wild-type*) (eq type2 *wild-type*))
          (values t t))
 	(t
-	 (multiple-value-bind (res win) (values-type-intersection type1 type2)
+	 (let ((res (values-type-intersection type1 type2)))
 	   (values (not (eq res *empty-type*))
-		   win)))))
+		   t)))))
 
 ;;; a SUBTYPEP-like operation that can be used on any types, including
 ;;; VALUES types
@@ -898,6 +907,17 @@
   (declare (type ctype type))
   (funcall (type-class-unparse (type-class-info type)) type))
 
+(defun-cached (type-negation :hash-function (lambda (type)
+					      (logand (type-hash-value type)
+						      #xff))
+			     :hash-bits 8
+			     :values 1
+			     :default nil
+			     :init-wrapper !cold-init-forms)
+              ((type eq))
+  (declare (type ctype type))
+  (funcall (type-class-negate (type-class-info type)) type))
+
 ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
 ;;; early-type.lisp by WHN ca. 19990201.)
 
@@ -927,65 +947,27 @@
 ;;;; These are fully general operations on CTYPEs: they'll always
 ;;;; return a CTYPE representing the result.
 
-;;; shared logic for unions and intersections: Return a vector of
+;;; shared logic for unions and intersections: Return a list of
 ;;; 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)
-  (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-probably-compound-type (constructor types enumerable identity)
-  (declare (type function constructor))
-  (declare (type (vector ctype) types))
-  (declare (type ctype identity))
-  (case (length types)
-    (0 identity)
-    (1 (aref types 0))
-    (t (funcall constructor
-		enumerable
-		;; FIXME: This should be just (COERCE TYPES 'LIST), but as
-		;; of sbcl-0.6.11.17 the COERCE optimizer is really
-		;; 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-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.
-		#+sb-xc-host (coerce types 'list)
-		#-sb-xc-host (coerce-to-list types)))))
-
+(macrolet
+    ((def (name compound-type-p simplify2)
+	 `(defun ,name (types)
+	    (when types
+	      (multiple-value-bind (first rest)
+		  (if (,compound-type-p (car types))
+		      (values (car (compound-type-types (car types)))
+			      (append (cdr (compound-type-types (car types)))
+				      (cdr types)))
+		      (values (car types) (cdr types)))
+		(let ((rest (,name rest)) u)
+		  (dolist (r rest (cons first rest))
+		    (when (setq u (,simplify2 first r))
+		      (return (,name (nsubstitute u r rest)))))))))))
+  (def simplify-intersections intersection-type-p type-intersection2)
+  (def simplify-unions union-type-p type-union2))
+		 
 (defun maybe-distribute-one-union (union-type types)
   (let* ((intersection (apply #'type-intersection types))
 	 (union (mapcar (lambda (x) (type-intersection x intersection))
@@ -1002,10 +984,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)))
-    (declare (type (vector ctype) simplified-types))
+  (let ((simplified-types (simplify-intersections input-types)))
+    (declare (type list simplified-types))
     ;; 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
@@ -1014,8 +994,7 @@
     ;; to end up with unreasonably huge type expressions. So instead
     ;; we try to generate a simple type by distributing the union; if
     ;; the type can't be made simple, we punt to HAIRY-TYPE.
-    (if (and (> (length simplified-types) 1)
-	     (some #'union-type-p simplified-types))
+    (if (and (cdr simplified-types) (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))
@@ -1027,11 +1006,12 @@
 	       :specifier `(and ,@(map 'list
 				       #'type-specifier
 				       simplified-types)))))
-	(make-probably-compound-type #'%make-intersection-type
-				     simplified-types
-				     (some #'type-enumerable
-					   simplified-types)
-				     *universal-type*))))
+	(cond
+	  ((null simplified-types) *universal-type*)
+	  ((null (cdr simplified-types)) (car simplified-types))
+	  (t (%make-intersection-type
+	      (some #'type-enumerable simplified-types)
+	      simplified-types))))))
 
 (defun type-union (&rest input-types)
   (%type-union input-types))
@@ -1039,13 +1019,13 @@
                            :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-probably-compound-type #'make-union-type
-				 simplified-types
-				 (every #'type-enumerable simplified-types)
-				 *empty-type*)))
+  (let ((simplified-types (simplify-unions input-types)))
+    (cond
+      ((null simplified-types) *empty-type*)
+      ((null (cdr simplified-types)) (car simplified-types))
+      (t (make-union-type
+	  (every #'type-enumerable simplified-types)
+	  simplified-types)))))
 
 ;;;; built-in types
 
@@ -1159,11 +1139,21 @@
   ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type.
   (hierarchical-union2 type1 type2))
 
+(!define-type-method (named :negate) (x)
+  (aver (not (eq x *wild-type*)))
+  (cond
+    ((eq x *universal-type*) *empty-type*)
+    ((eq x *empty-type*) *universal-type*)
+    (t (bug "NAMED type not universal, wild or empty: ~S" x))))
+
 (!define-type-method (named :unparse) (x)
   (named-type-name x))
 
 ;;;; hairy and unknown types
 
+(!define-type-method (hairy :negate) (x)
+  (make-negation-type :type x))
+
 (!define-type-method (hairy :unparse) (x)
   (hairy-type-specifier x))
 
@@ -1183,7 +1173,12 @@
   (values nil nil))
 
 (!define-type-method (hairy :complex-=) (type1 type2)
-  (if (unknown-type-p type2)
+  (if (and (unknown-type-p type2)
+           (let* ((specifier2 (unknown-type-specifier type2))
+                  (name2 (if (consp specifier2)
+                             (car specifier2)
+                             specifier2)))
+             (info :type :kind name2)))
       (let ((type2 (specifier-type (unknown-type-specifier type2))))
         (if (unknown-type-p type2)
             (values nil nil)
@@ -1224,6 +1219,9 @@
 
 ;;;; negation types
 
+(!define-type-method (negation :negate) (x)
+  (negation-type-type x))
+
 (!define-type-method (negation :unparse) (x)
   `(not ,(type-specifier (negation-type-type x))))
 
@@ -1376,137 +1374,56 @@
   (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)))))
+  (type-negation (specifier-type typespec)))
 
 ;;;; numeric types
 
 (!define-type-class number)
 
+(declaim (inline numeric-type-equal))
+(defun numeric-type-equal (type1 type2)
+  (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))))
+
 (!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))
-	(eq (numeric-type-complexp type1) (numeric-type-complexp type2))
+   (and (numeric-type-equal type1 type2)
 	(equalp (numeric-type-low type1) (numeric-type-low type2))
 	(equalp (numeric-type-high type1) (numeric-type-high type2)))
    t))
 
+(!define-type-method (number :negate) (type)
+  (if (and (null (numeric-type-low type)) (null (numeric-type-high type)))
+      (make-negation-type :type type)
+      (type-union
+       (make-negation-type
+	:type (modified-numeric-type type :low nil :high nil))
+       (cond
+	 ((null (numeric-type-low type))
+	  (modified-numeric-type
+	   type
+	   :low (let ((h (numeric-type-high type)))
+		  (if (consp h) (car h) (list h)))
+	   :high nil))
+	 ((null (numeric-type-high type))
+	  (modified-numeric-type
+	   type
+	   :low nil
+	   :high (let ((l (numeric-type-low type)))
+		   (if (consp l) (car l) (list l)))))
+	 (t (type-union
+	     (modified-numeric-type
+	      type
+	      :low nil
+	      :high (let ((l (numeric-type-low type)))
+		      (if (consp l) (car l) (list l))))
+	     (modified-numeric-type
+	      type
+	      :low (let ((h (numeric-type-high type)))
+		     (if (consp h) (car h) (list h)))
+	      :high nil)))))))
+
 (!define-type-method (number :unparse) (type)
   (let* ((complexp (numeric-type-complexp type))
 	 (low (numeric-type-low type))
@@ -2188,6 +2105,12 @@
 			  (specialized-element-type-maybe type2)))
 	      t)))
 
+(!define-type-method (array :negate) (type)
+  ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the
+  ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY
+  ;; NIL) (ARRAY CHAR) ...) equivalent?  -- CSR, 2003-12-10
+  (make-negation-type :type type))
+
 (!define-type-method (array :unparse) (type)
   (let ((dims (array-type-dimensions type))
 	(eltype (type-specifier (array-type-element-type type)))
@@ -2202,25 +2125,21 @@
 		   (case eltype
 		     (bit 'bit-vector)
 		     (base-char 'base-string)
-		     (character 'string)
 		     (* 'vector)
 		     (t `(vector ,eltype)))
 		   (case eltype
 		     (bit `(bit-vector ,(car dims)))
 		     (base-char `(base-string ,(car dims)))
-		     (character `(string ,(car dims)))
 		     (t `(vector ,eltype ,(car dims)))))
 	       (if (eq (car dims) '*)
 		   (case eltype
 		     (bit 'simple-bit-vector)
 		     (base-char 'simple-base-string)
-		     (character 'simple-string)
 		     ((t) 'simple-vector)
 		     (t `(simple-array ,eltype (*))))
 		   (case eltype
 		     (bit `(simple-bit-vector ,(car dims)))
 		     (base-char `(simple-base-string ,(car dims)))
-		     (character `(simple-string ,(car dims)))
 		     ((t) `(simple-vector ,(car dims)))
 		     (t `(simple-array ,eltype ,dims))))))
 	  (t
@@ -2268,8 +2187,9 @@
 			  (specialized-element-type-maybe type2))
 		   t)))))
 
+;;; FIXME: is this dead?
 (!define-superclasses array
-  ((string string)
+  ((base-string base-string)
    (vector vector)
    (array))
   !cold-init-forms)
@@ -2372,6 +2292,42 @@
 
 (!define-type-class member)
 
+(!define-type-method (member :negate) (type)
+  (let ((members (member-type-members 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 type))))
+
 (!define-type-method (member :unparse) (type)
   (let ((members (member-type-members type)))
     (cond
@@ -2486,6 +2442,10 @@
 
 (!define-type-class intersection)
 
+(!define-type-method (intersection :negate) (type)
+  (apply #'type-union
+	 (mapcar #'type-negation (intersection-type-types type))))
+
 ;;; A few intersection types have special names. The others just get
 ;;; mechanically unparsed.
 (!define-type-method (intersection :unparse) (type)
@@ -2606,13 +2566,17 @@
 
 (!def-type-translator and (&whole whole &rest type-specifiers)
   (apply #'type-intersection
-	 (mapcar #'specifier-type
-		 type-specifiers)))
+	 (mapcar #'specifier-type type-specifiers)))
 
 ;;;; union types
 
 (!define-type-class union)
 
+(!define-type-method (union :negate) (type)
+  (declare (type ctype type))
+  (apply #'type-intersection
+	 (mapcar #'type-negation (union-type-types type))))
+
 ;;; The LIST, FLOAT and REAL types have special names.  Other union
 ;;; types just get mechanically unparsed.
 (!define-type-method (union :unparse) (type)
@@ -2623,6 +2587,8 @@
     ((type= type (specifier-type 'real)) 'real)
     ((type= type (specifier-type 'sequence)) 'sequence)
     ((type= type (specifier-type 'bignum)) 'bignum)
+    ((type= type (specifier-type 'simple-string)) 'simple-string)
+    ((type= type (specifier-type 'string)) 'string)
     (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
 
 ;;; Two union types are equal if they are each subtypes of each
@@ -2779,7 +2745,33 @@
   (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 :negate) (type)
+  (if (and (eq (cons-type-car-type type) *universal-type*)
+	   (eq (cons-type-cdr-type type) *universal-type*))
+      (make-negation-type :type type)
+      (type-union
+       (make-negation-type :type (specifier-type 'cons))
+       (cond
+	 ((and (not (eq (cons-type-car-type type) *universal-type*))
+	       (not (eq (cons-type-cdr-type type) *universal-type*)))
+	  (type-union
+	   (make-cons-type
+	    (type-negation (cons-type-car-type type))
+	    *universal-type*)
+	   (make-cons-type
+	    *universal-type*
+	    (type-negation (cons-type-cdr-type type)))))
+	 ((not (eq (cons-type-car-type type) *universal-type*))
+	  (make-cons-type
+	   (type-negation (cons-type-car-type type))
+	   *universal-type*))
+	 ((not (eq (cons-type-cdr-type type) *universal-type*))
+	  (make-cons-type
+	   *universal-type*
+	   (type-negation (cons-type-cdr-type type))))
+	 (t (bug "Weird CONS type ~S" type))))))
+
 (!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))))
@@ -2810,15 +2802,19 @@
   (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)))
+	(cdr-type2 (cons-type-cdr-type type2))
+	car-not1
+	car-not2)
     ;; UGH.  -- CSR, 2003-02-24
-    (macrolet ((frob-car (car1 car2 cdr1 cdr2)
+    (macrolet ((frob-car (car1 car2 cdr1 cdr2
+			  &optional (not1 nil not1p))
 		 `(type-union
 		   (make-cons-type ,car1 (type-union ,cdr1 ,cdr2))
 		   (make-cons-type
 		    (type-intersection ,car2
-		     (specifier-type
-		      `(not ,(type-specifier ,car1))))
+		     ,(if not1p
+			  not1
+			  `(type-negation ,car1)))
 		    ,cdr2))))
       (cond ((type= car-type1 car-type2)
 	     (make-cons-type car-type1
@@ -2830,6 +2826,15 @@
 	     (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))
+	    ;; more general case of the above, but harder to compute
+	    ((progn
+	       (setf car-not1 (type-negation car-type1))
+	       (not (csubtypep car-type2 car-not1)))
+	     (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
+	    ((progn
+	       (setf car-not2 (type-negation car-type2))
+	       (not (csubtypep car-type1 car-not2)))
+	     (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2))
 	    ;; 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)).
@@ -2842,14 +2847,21 @@
 	    
 (!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))))
-
+  (let ((car-int2 (type-intersection2 (cons-type-car-type type1)
+				      (cons-type-car-type type2)))
+	(cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
+				      (cons-type-cdr-type type2))))
+    (cond
+      ((and car-int2 cdr-int2) (make-cons-type car-int2 cdr-int2))
+      (car-int2 (make-cons-type car-int2
+				(type-intersection
+				 (cons-type-cdr-type type1)
+				 (cons-type-cdr-type type2))))
+      (cdr-int2 (make-cons-type
+		 (type-intersection (cons-type-car-type type1)
+				    (cons-type-car-type type2))
+		 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.
 ;;;