From: Nikodemus Siivola Date: Wed, 30 Nov 2011 10:21:05 +0000 (+0200) Subject: more conservative subtypep test for classoids X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b704b22c4bea05b9e6551ef0c0a26add7a7df083;p=sbcl.git more conservative subtypep test for classoids * Give NIL, NIL for invalid classoids with forward-referenced superclasses instead of signaling an error during SUBTYPEP. * If we can't tell it's a subtype and either has a forward-referenced superclass we can't tell for sure it isn't -- meaning NIL, NIL instead of NIL, T. Fixes the second half of lp#888630. --- diff --git a/NEWS b/NEWS index 24ee1fa..4ef4ab1 100644 --- a/NEWS +++ b/NEWS @@ -23,6 +23,8 @@ changes relative to sbcl-1.0.54: form that defines them. (lp#896379) * bug fix: DEFGENERIC warns about unsupported declarations, as specified by ANSI. (lp#894202) + * bug fix: SUBTYPEP tests involving forward-referenced classes no longer + bogusly report NIL, T. changes in sbcl-1.0.54 relative to sbcl-1.0.53: * minor incompatible changes: diff --git a/src/code/class.lisp b/src/code/class.lisp index b6c435c..c29bc8f 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -51,7 +51,7 @@ ;; :SEALED = We can't even add subclasses. ;; NIL = Anything could happen. (state nil :type (member nil :read-only :sealed)) - ;; direct superclasses of this class + ;; direct superclasses of this class. Always NIL for CLOS classes. (direct-superclasses () :type list) ;; representation of all of the subclasses (direct or indirect) of ;; this class. This is NIL if no subclasses or not initalized yet; @@ -854,30 +854,40 @@ ;;; We might be passed classoids with invalid layouts; in any pairwise ;;; class comparison, we must ensure that both are valid before ;;; proceeding. -(defun %ensure-classoid-valid (classoid layout) +(defun %ensure-classoid-valid (classoid layout error-context) (aver (eq classoid (layout-classoid layout))) - (when (layout-invalid layout) - (if (typep classoid 'standard-classoid) - (let ((class (classoid-pcl-class classoid))) - (cond - ((sb!pcl:class-finalized-p class) - (sb!pcl::%force-cache-flushes class)) - ((sb!pcl::class-has-a-forward-referenced-superclass-p class) - (error "Invalid, unfinalizeable class ~S (classoid ~S)." - class classoid)) - (t - (sb!pcl:finalize-inheritance class)))) - (error "Don't know how to ensure validity of ~S (not ~ - a STANDARD-CLASSOID)." classoid)))) - -(defun %ensure-both-classoids-valid (class1 class2) + (or (not (layout-invalid layout)) + (if (typep classoid 'standard-classoid) + (let ((class (classoid-pcl-class classoid))) + (cond + ((sb!pcl:class-finalized-p class) + (sb!pcl::%force-cache-flushes class) + t) + ((sb!pcl::class-has-a-forward-referenced-superclass-p class) + (when error-context + (bug "~@" + class + (sb!pcl::class-has-a-forward-referenced-superclass-p class) + error-context)) + nil) + (t + (sb!pcl:finalize-inheritance class) + t))) + (bug "~@" + classoid (or error-context 'subtypep))))) + +(defun %ensure-both-classoids-valid (class1 class2 &optional errorp) (do ((layout1 (classoid-layout class1) (classoid-layout class1)) (layout2 (classoid-layout class2) (classoid-layout class2)) (i 0 (+ i 1))) - ((and (not (layout-invalid layout1)) (not (layout-invalid layout2)))) + ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))) + t) (aver (< i 2)) - (%ensure-classoid-valid class1 layout1) - (%ensure-classoid-valid class2 layout2))) + (unless (and (%ensure-classoid-valid class1 layout1 errorp) + (%ensure-classoid-valid class2 layout2 errorp)) + (return-from %ensure-both-classoids-valid nil)))) (defun update-object-layout-or-invalid (object layout) (if (layout-for-std-class-p (layout-of object)) @@ -894,11 +904,22 @@ (!define-type-method (classoid :simple-subtypep) (class1 class2) (aver (not (eq class1 class2))) (with-world-lock () - (%ensure-both-classoids-valid class1 class2) - (let ((subclasses (classoid-subclasses class2))) - (if (and subclasses (gethash class1 subclasses)) - (values t t) - (values nil t))))) + (if (%ensure-both-classoids-valid class1 class2) + (let ((subclasses2 (classoid-subclasses class2))) + (if (and subclasses2 (gethash class1 subclasses2)) + (values t t) + (if (and (typep class1 'standard-classoid) + (typep class2 'standard-classoid) + (or (sb!pcl::class-has-a-forward-referenced-superclass-p + (classoid-pcl-class class1)) + (sb!pcl::class-has-a-forward-referenced-superclass-p + (classoid-pcl-class class2)))) + ;; If there's a forward-referenced class involved we don't know for sure. + ;; (There are cases which we /could/ figure out, but that doesn't seem + ;; to be required or important, really.) + (values nil nil) + (values nil t)))) + (values nil nil)))) ;;; When finding the intersection of a sealed class and some other ;;; class (not hierarchically related) the intersection is the union @@ -919,7 +940,7 @@ (!define-type-method (classoid :simple-intersection2) (class1 class2) (declare (type classoid class1 class2)) (with-world-lock () - (%ensure-both-classoids-valid class1 class2) + (%ensure-both-classoids-valid class1 class2 "type intersection") (cond ((eq class1 class2) class1) ;; If one is a subclass of the other, then that is the diff --git a/src/code/typep.lisp b/src/code/typep.lisp index ccd6641..531b1ab 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -199,7 +199,7 @@ (aver (< i 2)) (when (layout-invalid obj-layout) (setq obj-layout (update-object-layout-or-invalid object layout))) - (%ensure-classoid-valid classoid layout)) + (%ensure-classoid-valid classoid layout "typep")) (let ((obj-inherits (layout-inherits obj-layout))) (or (eq obj-layout layout) (dotimes (i (length obj-inherits) nil) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 261dbbd..9c077f9 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -845,7 +845,8 @@ (defun class-has-a-forward-referenced-superclass-p (class) - (or (forward-referenced-class-p class) + (or (when (forward-referenced-class-p class) + class) (some #'class-has-a-forward-referenced-superclass-p (class-direct-superclasses class)))) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 28479f0..91a1f69 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -732,4 +732,32 @@ (assert (not ok)) (assert sure)))) +(defclass subtypep-fwd-test1 (subtypep-fwd-test-unknown1) ()) +(defclass subtypep-fwd-test2 (subtypep-fwd-test-unknown2) ()) +(defclass subtypep-fwd-testb1 (subtypep-fwd-testb-unknown1) ()) +(defclass subtypep-fwd-testb2 (subtypep-fwd-testb-unknown2 subtypep-fwd-testb1) ()) +(with-test (:name (:subtypep :forward-referenced-classes)) + (flet ((test (c1 c2 b1 b2) + (multiple-value-bind (x1 x2) (subtypep c1 c2) + (unless (and (eq b1 x1) (eq b2 x2)) + (error "(subtypep ~S ~S) => ~S, ~S but wanted ~S, ~S" + c1 c2 x1 x2 b1 b2))))) + (test 'subtypep-fwd-test1 'subtypep-fwd-test1 t t) + (test 'subtypep-fwd-test2 'subtypep-fwd-test2 t t) + (test 'subtypep-fwd-test1 'subtypep-fwd-test2 nil nil) + (test 'subtypep-fwd-test2 'subtypep-fwd-test1 nil nil) + + (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown1 t t) + (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown2 t t) + (test 'subtypep-fwd-test1 'subtypep-fwd-test-unknown2 nil nil) + (test 'subtypep-fwd-test2 'subtypep-fwd-test-unknown1 nil nil) + + (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown2 t t) + (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown1 t t) + (test 'subtypep-fwd-test-unknown1 'subtypep-fwd-test-unknown2 nil nil) + (test 'subtypep-fwd-test-unknown2 'subtypep-fwd-test-unknown1 nil nil) + + (test 'subtypep-fwd-testb1 'subtypep-fwd-testb2 nil nil) + (test 'subtypep-fwd-testb2 'subtypep-fwd-testb1 t t))) + ;;; success