Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv22932/src/code
Modified Files:
late-type.lisp
Log Message:
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.
Index: late-type.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-type.lisp,v
retrieving revision 1.143
retrieving revision 1.144
diff -u -d -r1.143 -r1.144
--- late-type.lisp 8 Mar 2010 13:44:59 -0000 1.143
+++ late-type.lisp 18 Mar 2010 18:58:20 -0000 1.144
@@ -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)
|