From 184bdf08a1175e23253c28a235051869c1074636 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Thu, 9 Oct 2003 15:50:01 +0000
Subject: [PATCH] 	* src/code/type.lisp (cons) <simple-intersection>: Fix
 for 	SUBTYPE.CONS.23, for example.  From Christophe Rhodes, port from 
 SBCL.

---
 code/type.lisp | 23 +++++++++++++++--------
 1 file changed, 15 insertions(+), 8 deletions(-)

diff --git a/code/type.lisp b/code/type.lisp
index af19d71cd..537c7b178 100644
--- a/code/type.lisp
+++ b/code/type.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.64 2003/08/04 17:30:03 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.65 2003/10/09 15:50:01 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -3175,13 +3175,20 @@
 	    
 (define-type-method (cons :simple-intersection) (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)))))
 
 
 ;;; TYPE-DIFFERENCE  --  Interface
-- 
GitLab