X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fwrapper.lisp;h=9cd4e01a3326cf9f66b21d659dc24eb45d57803d;hb=d7cbe5c40e93796d326937f3fb962fa4d7b1fa85;hp=35ad695178f3693246c3187da8ada868bcdbba74;hpb=40660c4081a57a91e3cc3648a5aad3d3a95db938;p=sbcl.git

diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index 35ad695..9cd4e01 100644
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -34,7 +34,7 @@
 ;;; This is called in BRAID when we are making wrappers for classes
 ;;; whose slots are not initialized yet, and which may be built-in
 ;;; classes. We pass in the class name in addition to the class.
-(defun boot-make-wrapper (length name &optional class)
+(defun !boot-make-wrapper (length name &optional class)
   (let ((found (find-classoid name nil)))
     (cond
      (found
@@ -177,11 +177,28 @@
              ;;    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))
-             ;; 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)))
+             (let ((class (wrapper-class* owrapper)))
+               (%force-cache-flushes class)
+               ;; KLUDGE: avoid an infinite recursion, it's still better to
+               ;; bail out with an error for server softwares. see FIXME above.
+               ;; details: http://thread.gmane.org/gmane.lisp.steel-bank.devel/10175
+               ;;
+               ;; Error message here is trying to figure out a bit more about the
+               ;; situation, since we don't have anything approaching a test-case
+               ;; for the bug.
+               (let ((new-state (layout-invalid (wrapper-of instance))))
+                 (unless (neq t new-state)
+                   (cerror "Nevermind and recurse." 'bug
+                           :format-control "~@<~4IProblem forcing cache flushes. Please report ~
+                                               to sbcl-devel.~
+                                            ~% Owrapper: ~S~
+                                            ~% Wrapper-of: ~S~
+                                            ~% Class-wrapper: ~S~%~:@>"
+                           :format-arguments (mapcar (lambda (x)
+                                                       (cons x (layout-invalid x)))
+                                                     (list owrapper
+                                                           (wrapper-of instance)
+                                                           (class-wrapper class)))))))
              (check-wrapper-validity instance))
             ((consp state)
              (ecase (car state)