X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwrapper.lisp;h=d67e1c4775f0f5dd50aa7d0ea90c7c3faf89f269;hb=30b24d582dd8620b91c798e38a8aa9a6b999b4be;hp=1e8b2f83b9d67f54c2256e7fd67ac8ac482b1dd8;hpb=f73aadf04d841e0f1bfede4c11a13c4ba5c4e264;p=sbcl.git

diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index 1e8b2f8..d67e1c4 100644
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -99,8 +99,10 @@
 (declaim (inline wrapper-class*))
 (defun wrapper-class* (wrapper)
   (or (wrapper-class wrapper)
-      (ensure-non-standard-class
-       (classoid-name (layout-classoid wrapper)))))
+      (let ((classoid (layout-classoid wrapper)))
+        (ensure-non-standard-class
+         (classoid-name classoid)
+         classoid))))
 
 ;;; The wrapper cache machinery provides general mechanism for
 ;;; trapping on the next access to any instance of a given class. This
@@ -152,6 +154,9 @@
     (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)))
@@ -173,6 +178,10 @@
            ;;    INSTANCE's class.  See also the comment above
            ;;    FORCE-CACHE-FLUSHES.  Paul Dietz has test cases for this.
            (force-cache-flushes (class-of instance))
+           ;; KLUDGE avoid an infinite recursion, it's still better to
+           ;; bail out with an AVER for server softwares. see FIXME above.
+           ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175
+           (aver (not (eq (layout-invalid (wrapper-of instance)) t)))
            (check-wrapper-validity instance))
           ((consp state)
            (ecase (car state)
@@ -187,6 +196,12 @@
 (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.