From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Sun, 30 Nov 2003 16:08:48 +0000 (+0000)
Subject: 0.8.6.19:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9cf3dbee8c096c5ed739ae7afadff385f9c6a442;p=sbcl.git

0.8.6.19:
	Fix for CONS.SUBTYPEP.xx from PFD's test suite
	... more work in the CONS union method.

	                      ALERT ALERT ALERT

	this change reportedly makes PFD's random tester crawl, slowing it
	by a factor of 15 on input terms (type specifiers) of size 50.
	Options include
	  * ignoring this;
	  * having a cutoff in time or complexity beyond which we return
	    NIL, NIL;
	  * optimizing (NOT <cons>) some more;
	  * ...
	but at least it's slightly more correct now.
---

diff --git a/NEWS b/NEWS
index 239beb5..1f832e6 100644
--- a/NEWS
+++ b/NEWS
@@ -2208,6 +2208,9 @@ changes in sbcl-0.8.7 relative to sbcl-0.8.6:
     ** the value of the :REHASH-THRESHOLD argument to MAKE-HASH-TABLE
        is ignored if it is too small, rather than propagating through
        to cause DIVIDE-BY-ZERO or FLOATING-POINT-OVERFLOW errors.
+    ** extremely complex negations of CONS types were not being
+       sufficiently canonicalized, leading to inconsistencies in
+       SUBTYPEP.
 
 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 930ea76..c1a29d9 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -2778,15 +2778,20 @@
   (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
+			  `(specifier-type
+			    `(not ,(type-specifier ,car1)))))
 		    ,cdr2))))
       (cond ((type= car-type1 car-type2)
 	     (make-cons-type car-type1
@@ -2798,6 +2803,17 @@
 	     (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 (specifier-type
+			       `(not ,(type-specifier car-type1))))
+	       (not (csubtypep car-type2 car-not1)))
+	     (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1))
+	    ((progn
+	       (setf car-not2 (specifier-type
+			       `(not ,(type-specifier 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)).
diff --git a/version.lisp-expr b/version.lisp-expr
index 07e6d61..4c8bcc8 100644
--- 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".)
-"0.8.6.18"
+"0.8.6.19"