0.pre8.51:

        TYPE=-SET uses 3-values logic.

diff --git a/BUGS b/BUGS
index f43d6b2..23d87a5 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -845,6 +845,28 @@ WORKAROUND:
            (INTEGER 1296 1296)
            ...)>)[:EXTERNAL]
 
+  In recent SBCL the following example also illustrates this bug:
+
+    (time (compile
+           nil
+           '(lambda ()
+             (declare (optimize (safety 3)))
+             (declare (optimize (compilation-speed 2)))
+             (declare (optimize (speed 1) (debug 1) (space 1)))
+             (let ((start 4))
+               (declare (type (integer 0) start))
+               (print (incf start 22))
+               (print (incf start 26))
+               (print (incf start 28)))
+             (let ((start 6))
+               (declare (type (integer 0) start))
+               (print (incf start 22))
+               (print (incf start 26)))
+             (let ((start 10))
+               (declare (type (integer 0) start))
+               (print (incf start 22))
+               (print (incf start 26))))))
+
 190: "PPC/Linux pipe? buffer? bug"
   In sbcl-0.7.6, the run-program.test.sh test script sometimes hangs
   on the PPC/Linux platform, waiting for a zombie env process.  This

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 2d865d3..72e86e4 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -737,6 +737,7 @@ retained, possibly temporariliy, because it might be used internally."
              "CYCLIC-LIST-P"
             "COMPOUND-OBJECT-P"
              "SWAPPED-ARGS-FUN"
+             "AND/TYPE"
              "ANY/TYPE" "EVERY/TYPE"
             "EQUAL-BUT-NO-CAR-RECURSION"
              "TYPE-BOUND-NUMBER"

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 4522aa2..fe0f319 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -916,6 +916,15 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
 \f
 ;;;; utilities for two-VALUES predicates
 
+(defmacro and/type (x y)
+  `(multiple-value-bind (val1 win1) ,x
+     (if (and (not val1) win1)
+         (values nil t)
+         (multiple-value-bind (val2 win2) ,y
+           (if (and val1 val2)
+               (values t t)
+               (values nil (and win2 (not val2))))))))
+
 ;;; sort of like ANY and EVERY, except:
 ;;;   * We handle two-VALUES predicate functions, as SUBTYPEP does.
 ;;;     (And if the result is uncertain, then we return (VALUES NIL NIL),

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 15b8cb5..b1df87b 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -231,43 +231,35 @@
                     (csubtypep a1 a2)
                   (unless res (return (values res sure-p))))
              finally (return (values t t)))))
-   (macrolet ((3and (x y)
-                `(multiple-value-bind (val1 win1) ,x
-                   (if (and (not val1) win1)
-                       (values nil t)
-                       (multiple-value-bind (val2 win2) ,y
-                         (if (and val1 val2)
-                             (values t t)
-                             (values nil (and win2 (not val2)))))))))
-     (3and (values-subtypep (fun-type-returns type1)
-                            (fun-type-returns type2))
-           (cond ((fun-type-wild-args type2) (values t t))
-                 ((fun-type-wild-args type1)
-                  (cond ((fun-type-keyp type2) (values nil nil))
-                        ((not (fun-type-rest type2)) (values nil t))
-                        ((not (null (fun-type-required type2))) (values nil t))
-                        (t (3and (type= *universal-type* (fun-type-rest type2))
-                                 (every/type #'type= *universal-type*
-                                             (fun-type-optional type2))))))
-                 ((not (and (fun-type-simple-p type1)
-                            (fun-type-simple-p type2)))
-                  (values nil nil))
-                 (t (multiple-value-bind (min1 max1) (fun-type-nargs type1)
-                      (multiple-value-bind (min2 max2) (fun-type-nargs type2)
-                        (cond ((or (> max1 max2) (< min1 min2))
-                               (values nil t))
-                              ((and (= min1 min2) (= max1 max2))
-                               (3and (every-csubtypep (fun-type-required type1)
-                                                      (fun-type-required type2))
-                                     (every-csubtypep (fun-type-optional type1)
-                                                      (fun-type-optional type2))))
-                              (t (every-csubtypep
-                                  (concatenate 'list
-                                               (fun-type-required type1)
-                                               (fun-type-optional type1))
-                                  (concatenate 'list
-                                               (fun-type-required type2)
-                                               (fun-type-optional type2)))))))))))))
+   (and/type (values-subtypep (fun-type-returns type1)
+                              (fun-type-returns type2))
+             (cond ((fun-type-wild-args type2) (values t t))
+                   ((fun-type-wild-args type1)
+                    (cond ((fun-type-keyp type2) (values nil nil))
+                          ((not (fun-type-rest type2)) (values nil t))
+                          ((not (null (fun-type-required type2))) (values nil t))
+                          (t (and/type (type= *universal-type* (fun-type-rest type2))
+                                       (every/type #'type= *universal-type*
+                                                   (fun-type-optional type2))))))
+                   ((not (and (fun-type-simple-p type1)
+                              (fun-type-simple-p type2)))
+                    (values nil nil))
+                   (t (multiple-value-bind (min1 max1) (fun-type-nargs type1)
+                        (multiple-value-bind (min2 max2) (fun-type-nargs type2)
+                          (cond ((or (> max1 max2) (< min1 min2))
+                                 (values nil t))
+                                ((and (= min1 min2) (= max1 max2))
+                                 (and/type (every-csubtypep (fun-type-required type1)
+                                                            (fun-type-required type2))
+                                           (every-csubtypep (fun-type-optional type1)
+                                                            (fun-type-optional type2))))
+                                (t (every-csubtypep
+                                    (concatenate 'list
+                                                 (fun-type-required type1)
+                                                 (fun-type-optional type1))
+                                    (concatenate 'list
+                                                 (fun-type-required type2)
+                                                 (fun-type-optional type2))))))))))))
 
 (!define-superclasses function ((function)) !cold-init-forms)
 
@@ -2404,15 +2396,13 @@
 ;;; shared machinery for type equality: true if every type in the set
 ;;; TYPES1 matches a type in the set TYPES2 and vice versa
 (defun type=-set (types1 types2)
-  (flet (;; true if every type in the set X matches a type in the set Y
-        (type<=-set (x y)
+  (flet ((type<=-set (x y)
           (declare (type list x y))
-          (every (lambda (xelement)
-                   (position xelement y :test #'type=))
-                 x)))
-    (values (and (type<=-set types1 types2)
-                (type<=-set types2 types1))
-           t)))
+          (every/type (lambda (x y-element)
+                         (any/type #'type= y-element x))
+                       x y)))
+    (and/type (type<=-set types1 types2)
+              (type<=-set types2 types1))))
 
 ;;; Two intersection types are equal if their subtypes are equal sets.
 ;;;

diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp
index c4b282a..557b327 100644 (file)
--- a/tests/type.pure.lisp
+++ b/tests/type.pure.lisp
@@ -200,3 +200,6 @@
                        '(cons single-float single-float))))
 (assert (subtypep '(cons integer single-float)
                  '(or (cons fixnum single-float) (cons bignum single-float))))
+
+(assert (not (nth-value 1 (subtypep '(and null some-unknown-type)
+                                    'another-unknown-type))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 740dce8..adeac00 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.pre8.50"
+"0.pre8.51"