From f73aadf04d841e0f1bfede4c11a13c4ba5c4e264 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 1 Jul 2007 16:35:04 +0000 Subject: [PATCH] 1.0.7.7: slightly less broken handling of obsolete structures * Trap them correctly in PCL. * Correct package so that CLASSOID-TYPEP signals the correct error instead of running into an undefined function. * Tests. --- NEWS | 2 ++ src/code/class.lisp | 2 +- src/pcl/std-class.lisp | 2 +- src/pcl/wrapper.lisp | 47 +++++++++++++++++++++++++-------------------- tests/defstruct.impure.lisp | 28 +++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 59 insertions(+), 24 deletions(-) diff --git a/NEWS b/NEWS index 9897edaa0..3ef2a051b 100644 --- a/NEWS +++ b/NEWS @@ -7,6 +7,8 @@ changes in sbcl-1.0.8 relative to sbcl-1.0.7: and x86-64. * performance bug fix: GETHASH and (SETF GETHASH) are once again non-consing. + * bug fix: using obsoleted structure instances with TYPEP and + generic functions now signals a sensible error. * bug fix: threads waiting on GET-FOREGROUND can be interrupted. (reported by Kristoffer Kvello) * bug fix: backtrace construction is now more careful when making diff --git a/src/code/class.lisp b/src/code/class.lisp index e4cd365f1..b7ada1fc5 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -822,7 +822,7 @@ NIL is returned when no such class exists." (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))) + (sb!c::%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 diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 8b9b93915..9f2b8c1af 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -1357,7 +1357,7 @@ (type-of (obsolete-structure-datum condition)))))) (defun obsolete-instance-trap (owrapper nwrapper instance) - (if (not (pcl-instance-p instance)) + (if (not (layout-for-std-class-p owrapper)) (if *in-obsolete-instance-trap* *the-wrapper-of-structure-object* (let ((*in-obsolete-instance-trap* t)) diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index f8dc323d9..1e8b2f83b 100644 --- a/src/pcl/wrapper.lisp +++ b/src/pcl/wrapper.lisp @@ -156,27 +156,32 @@ (let* ((owrapper (wrapper-of instance)) (state (layout-invalid owrapper))) (aver (not (eq state :uninitialized))) - (etypecase state - (null owrapper) - ;; FIXME: I can't help thinking that, while this does cure the - ;; symptoms observed from some class redefinitions, this isn't - ;; the place to be doing this flushing. Nevertheless... -- - ;; CSR, 2003-05-31 - ;; - ;; CMUCL comment: - ;; We assume in this case, that the :INVALID is from a - ;; previous call to REGISTER-LAYOUT for a superclass of - ;; INSTANCE's class. See also the comment above - ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this. - ((member t) - (force-cache-flushes (class-of instance)) - (check-wrapper-validity instance)) - (cons - (ecase (car state) - (:flush - (flush-cache-trap owrapper (cadr state) instance)) - (:obsolete - (obsolete-instance-trap owrapper (cadr state) instance))))))) + (cond ((not state) + owrapper) + ((not (layout-for-std-class-p owrapper)) + ;; Obsolete structure trap. + (obsolete-instance-trap owrapper nil instance)) + ((eq t state) + ;; FIXME: I can't help thinking that, while this does cure + ;; the symptoms observed from some class redefinitions, + ;; this isn't the place to be doing this flushing. + ;; Nevertheless... -- CSR, 2003-05-31 + ;; + ;; CMUCL comment: + ;; We assume in this case, that the :INVALID is from a + ;; previous call to REGISTER-LAYOUT for a superclass of + ;; INSTANCE's class. See also the comment above + ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this. + (force-cache-flushes (class-of instance)) + (check-wrapper-validity instance)) + ((consp state) + (ecase (car state) + (:flush + (flush-cache-trap owrapper (cadr state) instance)) + (:obsolete + (obsolete-instance-trap owrapper (cadr state) instance)))) + (t + (bug "Invalid LAYOUT-INVALID: ~S" state))))) (declaim (inline check-obsolete-instance)) (defun check-obsolete-instance (instance) diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 83475d091..7e5fad911 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -671,5 +671,33 @@ (aref (vector x) (incf i))) (bug-348-x x)))) +;;; obsolete instance trapping +;;; +;;; FIXME: Both error conditions below should possibly be instances +;;; of the same class. (Putting this FIXME here, since this is the only +;;; place where they appear together.) + +(with-test (:name obsolete-defstruct/print-object) + (eval '(defstruct born-to-change)) + (let ((x (make-born-to-change))) + (handler-bind ((error 'continue)) + (eval '(defstruct born-to-change slot))) + (assert (eq :error + (handler-case + (princ-to-string x) + (sb-pcl::obsolete-structure () + :error)))))) + +(with-test (:name obsolete-defstruct/typep) + (eval '(defstruct born-to-change-2)) + (let ((x (make-born-to-change-2))) + (handler-bind ((error 'continue)) + (eval '(defstruct born-to-change-2 slot))) + (assert (eq :error2 + (handler-case + (typep x (find-class 'standard-class)) + (sb-kernel:layout-invalid () + :error2)))))) + ;;; success (format t "~&/returning success~%") diff --git a/version.lisp-expr b/version.lisp-expr index d317cdce5..05b223c30 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.7.6" +"1.0.7.7" -- 2.11.4.GIT