0.7.13.7:

	Fix really stupid bug in CONS :SIMPLE-UNION method
	... don't mix the CDR type into the CAR type
	While I'm there, make the CONS :SIMPLE-UNION method smarter
	... canonicalize unions of (CONS A D) with (CONS A' D'), where
	A subtypep A', to
		(OR (CONS A (OR D D')) (CONS (AND A' (NOT A)) D'))
	the point being that this is then in a form that can be	further
	canonicalized when more CONS types come along. 	This fixes about
	5 bugs from pfdietz's suite.

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 623ff1c..0feadf6 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -2681,13 +2681,35 @@
        (car-type2 (cons-type-car-type type2))
        (cdr-type1 (cons-type-cdr-type type1))
        (cdr-type2 (cons-type-cdr-type type2)))
-    (cond ((type= car-type1 car-type2)
-          (make-cons-type car-type1
-                          (type-union cdr-type1 cdr-type2)))
-         ((type= cdr-type1 cdr-type2)
-          (make-cons-type (type-union cdr-type1 cdr-type2)
-                          cdr-type1)))))
-
+    ;; UGH.  -- CSR, 2003-02-24
+    (macrolet ((frob-car (car1 car2 cdr1 cdr2)
+                `(type-union
+                  (make-cons-type ,car1 (type-union ,cdr1 ,cdr2))
+                  (make-cons-type
+                   (type-intersection ,car2
+                    (specifier-type
+                     `(not ,(type-specifier ,car1))))
+                   ,cdr2))))
+      (cond ((type= car-type1 car-type2)
+            (make-cons-type car-type1
+                            (type-union cdr-type1 cdr-type2)))
+           ((type= cdr-type1 cdr-type2)
+            (make-cons-type (type-union car-type1 car-type2)
+                            cdr-type1))
+           ((csubtypep car-type1 car-type2)
+            (frob-car car-type1 car-type2 cdr-type1 cdr-type2))
+           ((csubtypep car-type2 car-type1)
+            (frob-car car-type2 car-type1 cdr-type2 cdr-type1))
+           ;; Don't put these in -- consider the effect of taking the
+           ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and
+           ;; (CONS (INTEGER 0 3) (INTEGER 5 6)).
+           #+nil
+           ((csubtypep cdr-type1 cdr-type2)
+            (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2))
+           #+nil
+           ((csubtypep cdr-type2 cdr-type1)
+            (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1))))))
+           
 (!define-type-method (cons :simple-intersection2) (type1 type2)
   (declare (type cons-type type1 type2))
   (let (car-int2

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index 5c570c9..fd8409e 100644 (file)
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -193,3 +193,10 @@
                  '(rational 0 10)))
 (assert (subtypep '(rational 0 10)
                  '(or (eql 0) (rational (0) 10))))
+;;; Until sbcl-0.7.13.7, union of CONS types when the CDRs were the
+;;; same type gave exceedingly wrong results
+(assert (null (subtypep '(or (cons fixnum single-float)
+                            (cons bignum single-float))
+                       '(cons single-float single-float))))
+(assert (subtypep '(cons integer single-float)
+                 '(or (cons fixnum single-float) (cons bignum single-float))))
\ No newline at end of file

diff --git a/version.lisp-expr b/version.lisp-expr
index 776bb31..1a95f6f 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.13.6"
+"0.7.13.7"