From 8aa1742a4cf5fb4752148ace41a779482b195bd4 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 8 Aug 2006 20:14:21 +0000 Subject: [PATCH] 0.9.15.17: OK then. Fix %INSTANCE-TYPEP deftransform ... if we're testing for a structure-classoid, then any object with an invalid layout is neccessarily not typep that class. ... if we're testing for something with a fixed depthoid (i.e. something which is always at a given position in the layout-inherits), then if we get an object with an invalid layout we mustn't throw an error before trying to update the object. --- NEWS | 2 ++ package-data-list.lisp-expr | 1 + src/code/class.lisp | 5 +++++ src/code/typep.lisp | 6 +----- src/compiler/typetran.lisp | 18 +++++++++++------- tests/clos.impure.lisp | 14 ++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 35 insertions(+), 13 deletions(-) diff --git a/NEWS b/NEWS index 1ca2644..6e3cb20 100644 --- a/NEWS +++ b/NEWS @@ -16,6 +16,8 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: defaults. * bug fix: erronous calls to PATHNAME were being optimized away. (reported by Richard Kreuter) + * bug fix: compiled calls to TYPEP were mishandling obsolete + instances. (reported by James Bielman and Attila Lendvai) changes in sbcl-0.9.15 relative to sbcl-0.9.14: * added support for the ucs-2 external format. (contributed by Ivan diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index ac421d6..53148b3 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1463,6 +1463,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR" ;; FIXME: 32/64-bit issues "UNSIGNED-BYTE-32-P" "UNSIGNED-BYTE-64-P" + "UPDATE-OBJECT-LAYOUT-OR-INVALID" "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-SPECIFIER-TYPE" "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP" "VALUES-TYPE" "VALUES-TYPE-ERROR" "VALUES-TYPE-IN" diff --git a/src/code/class.lisp b/src/code/class.lisp index dc0b524..0390b9f 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -847,6 +847,11 @@ NIL is returned when no such class exists." (ensure-classoid-valid class1 layout1) (ensure-classoid-valid class2 layout2))) +(defun update-object-layout-or-invalid (object layout) + (if (typep (classoid-of object) 'standard-classoid) + (sb!pcl::check-wrapper-validity object) + (%layout-invalid-error object layout))) + ;;; Simple methods for TYPE= and SUBTYPEP should never be called when ;;; the two classes are equal, since there are EQ checks in those ;;; operations. diff --git a/src/code/typep.lisp b/src/code/typep.lisp index 36e776a..ca3c349 100644 --- a/src/code/typep.lisp +++ b/src/code/typep.lisp @@ -185,11 +185,7 @@ (values obj-layout layout)) (aver (< i 2)) (when (layout-invalid obj-layout) - (if (typep (classoid-of object) 'standard-classoid) - (setq obj-layout (sb!pcl::check-wrapper-validity object)) - (error "~S was called on an obsolete object (classoid ~S)." - 'typep - (classoid-proper-name (layout-classoid obj-layout))))) + (setq obj-layout (update-object-layout-or-invalid object layout))) (ensure-classoid-valid classoid layout)) (let ((obj-inherits (layout-inherits obj-layout))) (or (eq obj-layout layout) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 6405bdd..e5091d1 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -443,9 +443,13 @@ (n-layout (gensym))) `(and (,pred object) (let ((,n-layout (,get-layout object))) - ,@(when (policy *lexenv* (>= safety speed)) - `((when (layout-invalid ,n-layout) - (%layout-invalid-error object ',layout)))) + ;; we used to check for invalid layouts here, + ;; but in fact that's both unnecessary and + ;; wrong; it's unnecessary because structure + ;; classes can't be redefined, and it's wrong + ;; because it is quite legitimate to pass an + ;; object with an invalid layout to a structure + ;; type test. (if (eq ,n-layout ',layout) t (and (> (layout-depthoid ,n-layout) @@ -456,15 +460,15 @@ ',layout)))))))) ((and layout (>= (layout-depthoid layout) 0)) ;; hierarchical layout depths for other things (e.g. - ;; CONDITIONs) + ;; CONDITION, STREAM) (let ((depthoid (layout-depthoid layout)) (n-layout (gensym)) (n-inherits (gensym))) `(and (,pred object) (let ((,n-layout (,get-layout object))) - ,@(when (policy *lexenv* (>= safety speed)) - `((when (layout-invalid ,n-layout) - (%layout-invalid-error object ',layout)))) + (when (layout-invalid ,n-layout) + (setq ,n-layout (update-object-layout-or-invalid + object ',layout))) (if (eq ,n-layout ',layout) t (let ((,n-inherits (layout-inherits ,n-layout))) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index f05a40e..84c7ec3 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1369,4 +1369,18 @@ (assert (equal '(result) (test-mc27prime 3))) (assert (raises-error? (test-mc27 t))) ; still no-applicable-method +;;; more invalid wrappers. This time for a long-standing bug in the +;;; compiler's expansion for TYPEP on various class-like things, with +;;; user-visible consequences. +(defclass obsolete-again () ()) +(defvar *obsolete-again* (make-instance 'obsolete-again)) +(defvar *obsolete-again-hash* (sxhash *obsolete-again*)) +(make-instances-obsolete (find-class 'obsolete-again)) +(assert (not (streamp *obsolete-again*))) +(make-instances-obsolete (find-class 'obsolete-again)) +(assert (= (sxhash *obsolete-again*) *obsolete-again-hash*)) +(compile (defun is-a-structure-object-p (x) (typep x 'structure-object))) +(make-instances-obsolete (find-class 'obsolete-again)) +(assert (not (is-a-structure-object-p *obsolete-again*))) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 938b383..5309947 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".) -"0.9.15.16" +"0.9.15.17" -- 1.7.10.4