X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwrapper.lisp;h=eb567cd36ba5854f73daedceb8faffb901b1ba73;hb=9c61930488da84cccaeaaabea55d3ad4e1323fda;hp=f8dc323d9b8865a4dadc8724bd9704dccf9f967f;hpb=8fee0ba99cd1b1038072bd3fc8f5d5338d80d2de;p=sbcl.git

diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index f8dc323..eb567cd 100644
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -152,36 +152,50 @@
     (remhash owrapper *previous-nwrappers*)
     (setf (gethash nwrapper *previous-nwrappers*) new-previous)))
 
+;;; FIXME: This is not a good name: part of the constract here is that
+;;; we return the valid wrapper, which is not obvious from the name
+;;; (or the names of our callees.)
 (defun check-wrapper-validity (instance)
   (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)
   (when (invalid-wrapper-p (layout-of instance))
     (check-wrapper-validity instance)))
+
+(defun valid-wrapper-of (instance)
+  (let ((wrapper (wrapper-of instance)))
+    (if (invalid-wrapper-p wrapper)
+        (check-wrapper-validity instance)
+        wrapper)))
 
 ;;;  NIL: means nothing so far, no actual arg info has NILs in the
 ;;;  metatype.