0.8.4.9:

	Fix bug in CONS types/SUBTYPEP
	... actually a bug in the CONS :SIMPLE-INTERSECTION2 type
		method, which wasn't doing enough work when one of the
		types produced a useful intersection and the other
		not.

diff --git a/NEWS b/NEWS
index 68014ed..d57ed10 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2129,6 +2129,8 @@ changes in sbcl-0.8.5 relative to sbcl-0.8.4:
        interval, containing 0.
     ** ASH of a negative bignum by a negative bignum count now returns
        -1, not 0.
        interval, containing 0.
     ** ASH of a negative bignum by a negative bignum count now returns
        -1, not 0.

+    ** intersection of CONS types now canonicalizes properly, fixing
+       inconsistencies in SUBTYPEP.

 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index b2cedaf..930ea76 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -2810,14 +2810,21 @@
            
 (!define-type-method (cons :simple-intersection2) (type1 type2)
   (declare (type cons-type type1 type2))
            
 (!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))))
-\f
+  (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)))))
+\f                               

 ;;; 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.
 ;;;
 ;;; 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.
 ;;;

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index 6e4a2e8..38cee27 100644 (file)
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -409,6 +409,14 @@
         (t1 (sb-kernel:specifier-type s)))
    (eval `(defstruct ,s))
    (sb-kernel:type= t1 (sb-kernel:specifier-type s))))
         (t1 (sb-kernel:specifier-type s)))
    (eval `(defstruct ,s))
    (sb-kernel:type= t1 (sb-kernel:specifier-type s))))

+
+;;; bug found by PFD's random subtypep tester
+(let ((t1 '(cons rational (cons (not rational) (cons integer t))))
+      (t2 '(not (cons (integer 0 1) (cons single-float long-float)))))
+  (assert-t-t (subtypep t1 t2))
+  (assert-nil-t (subtypep t2 t1))
+  (assert-t-t (subtypep `(not ,t2) `(not ,t1)))
+  (assert-nil-t (subtypep `(not ,t1) `(not ,t2))))

 \f
 ;;; success
 (quit :unix-status 104)
 \f
 ;;; success
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 8e856ab..e3d38c5 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

-"0.8.4.8"
+"0.8.4.9"