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.

diff --git a/NEWS b/NEWS
index 9897eda..3ef2a05 100644 (file)
--- 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 e4cd365..b7ada1f 100644 (file)
--- 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 8b9b939..9f2b8c1 100644 (file)
--- 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 f8dc323..1e8b2f8 100644 (file)
--- 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 83475d0..7e5fad9 100644 (file)
--- 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 d317cdc..05b223c 100644 (file)
--- 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"