From 9f13d0bd64a14870487daa2e62ea005965b04eac Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 18 Mar 2010 18:58:20 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ src/code/late-type.lisp | 71 ++++++++++++++++++++++++++++++++--------------- tests/type.impure.lisp | 26 +++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 78 insertions(+), 23 deletions(-) diff --git a/NEWS b/NEWS index 5642bc6..b0813e2 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4