1.0.36.32: reparsing undefined types when necessary

 In type methods for unknown types that have since parsing become
 defined, update the type as necessary.

 Fixes bug #309128.

diff --git a/NEWS b/NEWS
index 5642bc6..b0813e2 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -53,6 +53,8 @@ changes relative to sbcl-1.0.36:
   * bug fix: LOOP OF-TYPE VECTOR compile-time error. (lp#540186)
   * bug fix: SIGNAL SB-SYS:INTERACTIVE-INTERRUPT before entering the debugger
     due to it, so that handlers can run.
+  * bug fix: reparsing undefined types if they have become defined since
+    parsing. (lp#309128)
 
 changes in sbcl-1.0.36 relative to sbcl-1.0.35:
   * new feature: SB-EXT:TYPEXPAND-1, SB-EXT:TYPEXPAND, and

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index bf4630a..609d33c 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1373,41 +1373,68 @@
 (!define-type-method (hairy :unparse) (x)
   (hairy-type-specifier x))
 
+(defun maybe-specifier-for-reparse (type)
+  (when (unknown-type-p type)
+    (let* ((spec (unknown-type-specifier type))
+           (name (if (consp spec)
+                     (car spec)
+                     spec)))
+      (when (info :type :kind name)
+        spec))))
+
+;;; Evil macro.
+(defmacro maybe-reparse-specifier! (type)
+  (assert (symbolp type))
+  (with-unique-names (spec)
+    `(let ((,spec (maybe-specifier-for-reparse ,type)))
+       (when ,spec
+         (setf ,type (specifier-type ,spec))
+         t))))
+
 (!define-type-method (hairy :simple-subtypep) (type1 type2)
   (let ((hairy-spec1 (hairy-type-specifier type1))
         (hairy-spec2 (hairy-type-specifier type2)))
     (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2)
            (values t t))
+          ((maybe-reparse-specifier! type1)
+           (if (unknown-type-p type1)
+               (values nil nil)
+               (csubtypep type1 type2)))
+          ((maybe-reparse-specifier! type2)
+           (if (unknown-type-p type2)
+               (values nil nil)
+               (csubtypep type1 type2)))
           (t
            (values nil nil)))))
 
 (!define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
-  (let ((specifier (hairy-type-specifier type2)))
-    (cond
-      ((and (consp specifier) (eql (car specifier) 'satisfies))
-       (case (cadr specifier)
-         ((keywordp) (if (type= type1 (specifier-type 'symbol))
-                         (values nil t)
-                         (invoke-complex-subtypep-arg1-method type1 type2)))
-         (t (invoke-complex-subtypep-arg1-method type1 type2))))
-      (t (invoke-complex-subtypep-arg1-method type1 type2)))))
+  (if (maybe-reparse-specifier! type2)
+      (if (unknown-type-p type2)
+          (values nil nil)
+          (csubtypep type1 type2))
+      (let ((specifier (hairy-type-specifier type2)))
+        (cond ((and (consp specifier) (eql (car specifier) 'satisfies))
+               (case (cadr specifier)
+                 ((keywordp) (if (type= type1 (specifier-type 'symbol))
+                                 (values nil t)
+                                 (invoke-complex-subtypep-arg1-method type1 type2)))
+                 (t (invoke-complex-subtypep-arg1-method type1 type2))))
+              (t
+               (invoke-complex-subtypep-arg1-method type1 type2))))))
 
 (!define-type-method (hairy :complex-subtypep-arg1) (type1 type2)
-  (declare (ignore type1 type2))
-  (values nil nil))
+  (if (maybe-reparse-specifier! type1)
+      (if (unknown-type-p type1)
+          (values nil nil)
+          (csubtypep type1 type2))
+      (values nil nil)))
 
 (!define-type-method (hairy :complex-=) (type1 type2)
-  (if (and (unknown-type-p type2)
-           (let* ((specifier2 (unknown-type-specifier type2))
-                  (name2 (if (consp specifier2)
-                             (car specifier2)
-                             specifier2)))
-             (info :type :kind name2)))
-      (let ((type2 (specifier-type (unknown-type-specifier type2))))
-        (if (unknown-type-p type2)
-            (values nil nil)
-            (type= type1 type2)))
-  (values nil nil)))
+  (if (maybe-reparse-specifier! type2)
+      (if (unknown-type-p type2)
+          (values nil nil)
+          (type= type1 type2))
+      (values nil nil)))
 
 (!define-type-method (hairy :simple-intersection2 :complex-intersection2)
                      (type1 type2)

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index aedea6b..a992a15 100644 (file)
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -697,4 +697,30 @@
                      ftype )
              (error "FAILURE")))))))
 
+(with-test (:name (:bug-309128 1))
+  (let* ((s (gensym))
+         (t1 (sb-kernel:specifier-type s)))
+    (eval `(defstruct ,s))
+    (multiple-value-bind (ok sure)
+        (sb-kernel:csubtypep t1 (sb-kernel:specifier-type s))
+      (assert (and ok sure)))))
+
+(with-test (:name (:bug-309128 2))
+  (let* ((s (gensym))
+         (t1 (sb-kernel:specifier-type s)))
+    (eval `(defstruct ,s))
+    (multiple-value-bind (ok sure)
+        (sb-kernel:csubtypep (sb-kernel:specifier-type s) t1)
+      (assert (and ok sure)))))
+
+(with-test (:name (:bug-309128 3))
+  (let* ((s (gensym))
+         (t1 (sb-kernel:specifier-type s))
+         (s2 (gensym))
+         (t2 (sb-kernel:specifier-type s2)))
+    (eval `(deftype ,s2 () ',s))
+    (eval `(defstruct ,s))
+    (multiple-value-bind (ok sure) (sb-kernel:csubtypep t1 t2)
+      (assert (and ok sure)))))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index c7ed064..2f66a6e 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".)
-"1.0.36.31"
+"1.0.36.32"