X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=ac0ce019b20f8193caf7608399a9db2285b50308;hb=8b64d57b865fec6ba082dda965146b5e8aa877b3;hp=b2cedaf2c46b295583b2d8c1336642fd8832d969;hpb=7ff14ce5fb7d138d2cd39eb6364e5ae175ac1838;p=sbcl.git

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index b2cedaf..ac0ce01 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
@@ -301,6 +307,10 @@
     ((csubtypep type1 (specifier-type 'function)) nil)
     (t :call-other-method)))
 (!define-type-method (function :complex-union2) (type1 type2)
+  (declare (ignore type2))
+  ;; TYPE2 is a FUNCTION type.  If TYPE1 is a classoid type naming
+  ;; FUNCTION, then it is the union of the two; otherwise, there is no
+  ;; special union.
   (cond
     ((type= type1 (specifier-type 'function)) type1)
     (t nil)))
@@ -318,6 +328,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))))
 
@@ -898,6 +911,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.)
 
@@ -1011,11 +1035,6 @@
 
 (!define-type-class named)
 
-(defvar *wild-type*)
-(defvar *empty-type*)
-(defvar *universal-type*)
-(defvar *universal-fun-type*)
-
 (!cold-init-forms
  (macrolet ((frob (name var)
 	      `(progn
@@ -1119,11 +1138,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))
 
@@ -1189,8 +1218,13 @@
 
 ;;;; 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))))
+  (if (type= (negation-type-type x) (specifier-type 'cons))
+      'atom
+      `(not ,(type-specifier (negation-type-type x)))))
 
 (!define-type-method (negation :simple-subtypep) (type1 type2)
   (csubtypep (negation-type-type type2) (negation-type-type type1)))
@@ -1341,123 +1375,7 @@
   (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
 
@@ -1476,6 +1394,37 @@
 	(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))
@@ -1516,9 +1465,8 @@
 	(:real
 	 base+bounds)
 	(:complex
-	 (if (eq base+bounds 'real)
-	     'complex
-	     `(complex ,base+bounds)))
+	 (aver (neq base+bounds 'real))
+	 `(complex ,base+bounds))
 	((nil)
 	 (aver (eq base+bounds 'real))
 	 'number)))))
@@ -1754,68 +1702,40 @@
 
 (!def-type-translator complex (&optional (typespec '*))
   (if (eq typespec '*)
-      (make-numeric-type :complexp :complex)
+      (specifier-type '(complex real))
       (labels ((not-numeric ()
 		 (error "The component type for COMPLEX is not numeric: ~S"
 			typespec))
 	       (not-real ()
-	         (error "The component type for COMPLEX is not real: ~S"
+	         (error "The component type for COMPLEX is not a subtype of REAL: ~S"
 			typespec))
 	       (complex1 (component-type)
 	         (unless (numeric-type-p component-type)
 		   (not-numeric))
 		 (when (eq (numeric-type-complexp component-type) :complex)
 		   (not-real))
-		 (modified-numeric-type component-type :complexp :complex))
-	       (complex-union (component)
-		 (unless (numberp component)
-		   (not-numeric))
-		 ;; KLUDGE: This TYPECASE more or less does
-		 ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF COMPONENT)),
-		 ;; (plus a small hack to treat (EQL COMPONENT 0) specially)
-		 ;; but uses logic cut and pasted from the DEFUN of
-		 ;; UPGRADED-COMPLEX-PART-TYPE. That's fragile, because
-		 ;; changing the definition of UPGRADED-COMPLEX-PART-TYPE
-		 ;; would tend to break the code here. Unfortunately,
-		 ;; though, reusing UPGRADED-COMPLEX-PART-TYPE here
-		 ;; would cause another kind of fragility, because
-		 ;; ANSI's definition of TYPE-OF is so weak that e.g.
-		 ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF 1/2)) could
-		 ;; end up being (UPGRADED-COMPLEX-PART-TYPE 'REAL)
-		 ;; instead of (UPGRADED-COMPLEX-PART-TYPE 'RATIONAL).
-		 ;; So using TYPE-OF would mean that ANSI-conforming
-		 ;; maintenance changes in TYPE-OF could break the code here.
-		 ;; It's not clear how best to fix this. -- WHN 2002-01-21,
-		 ;; trying to summarize CSR's concerns in his patch
-		 (typecase component
-		   (complex (error "The component type for COMPLEX (EQL X) ~
-                                    is complex: ~S"
-				   component))
-		   ((eql 0) (specifier-type nil)) ; as required by ANSI
-		   (single-float (specifier-type '(complex single-float)))
-		   (double-float (specifier-type '(complex double-float)))
-		   #!+long-float
-		   (long-float (specifier-type '(complex long-float)))
-		   (rational (specifier-type '(complex rational)))
-		   (t (specifier-type '(complex real))))))
+		 (if (csubtypep component-type (specifier-type '(eql 0)))
+		     *empty-type*
+		     (modified-numeric-type component-type
+					    :complexp :complex))))
 	(let ((ctype (specifier-type typespec)))
-	  (typecase ctype
-	    (numeric-type (complex1 ctype))
-	    (union-type (apply #'type-union
-			       ;; FIXME: This code could suffer from
-			       ;; (admittedly very obscure) cases of
-			       ;; bug 145 e.g. when TYPE is
-			       ;;   (OR (AND INTEGER (SATISFIES ODDP))
-			       ;;       (AND FLOAT (SATISFIES FOO))
-			       ;; and not even report the problem very well.
-			       (mapcar #'complex1
-				       (union-type-types ctype))))
-	    ;; MEMBER-TYPE is almost the same as UNION-TYPE, but
-	    ;; there's a gotcha: (COMPLEX (EQL 0)) is, according to
-	    ;; ANSI, equal to type NIL, the empty set.
-	    (member-type (apply #'type-union
-				(mapcar #'complex-union
-					(member-type-members ctype))))
+	  (cond
+	    ((eq ctype *empty-type*) *empty-type*)
+	    ((eq ctype *universal-type*) (not-real))
+	    ((typep ctype 'numeric-type) (complex1 ctype))
+	    ((typep ctype 'union-type)
+	     (apply #'type-union
+		    ;; FIXME: This code could suffer from (admittedly
+		    ;; very obscure) cases of bug 145 e.g. when TYPE
+		    ;; is
+		    ;;   (OR (AND INTEGER (SATISFIES ODDP))
+		    ;;       (AND FLOAT (SATISFIES FOO))
+		    ;; and not even report the problem very well.
+		    (mapcar #'complex1 (union-type-types ctype))))
+	    ((typep ctype 'member-type)
+	     (apply #'type-union
+		    (mapcar (lambda (x) (complex1 (ctype-of x)))
+			    (member-type-members ctype))))
 	    (t
 	     (multiple-value-bind (subtypep certainly)
 		 (csubtypep ctype (specifier-type 'real))
@@ -2144,7 +2064,7 @@
       (multiple-value-bind (equalp certainp)
 	  (type= (array-type-element-type type1)
 		 (array-type-element-type type2))
-	;; by its nature, the call to TYPE= should never return NIL,
+	;; By its nature, the call to TYPE= should never return NIL,
 	;; T, as we don't know what the UNKNOWN-TYPE will grow up to
 	;; be.  -- CSR, 2002-08-19
 	(aver (not (and (not equalp) certainp)))
@@ -2157,6 +2077,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)))
@@ -2338,6 +2264,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
@@ -2422,7 +2384,7 @@
 	    (float (if (zerop m)
 		       (push m ms)
 		       (push (ctype-of m) numbers)))
-	    (number (push (ctype-of m) numbers))
+	    (real (push (ctype-of m) numbers))
 	    (t (push m ms))))
 	(apply #'type-union
 	       (if ms
@@ -2452,6 +2414,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)
@@ -2572,13 +2538,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)
@@ -2591,6 +2561,7 @@
     ((type= type (specifier-type 'bignum)) 'bignum)
     ((type= type (specifier-type 'simple-string)) 'simple-string)
     ((type= type (specifier-type 'string)) 'string)
+    ((type= type (specifier-type 'complex)) 'complex)
     (t `(or ,@(mapcar #'type-specifier (union-type-types type))))))
 
 ;;; Two union types are equal if they are each subtypes of each
@@ -2747,7 +2718,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))))
@@ -2778,15 +2775,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
@@ -2798,6 +2799,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)).
@@ -2810,14 +2820,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.
 ;;;