From: Christophe Rhodes <csr21@cantab.net>
Date: Fri, 11 Nov 2011 16:47:30 +0000 (+0000)
Subject: fix out-of-line structure predicates on obsolete standard-instances
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=40660c4081a57a91e3cc3648a5aad3d3a95db938;p=sbcl.git

fix out-of-line structure predicates on obsolete standard-instances

Apply the same fix to typep-to-layout that I did over five years ago
to the various inline / compiler transforms.  Include an out-of-line
test case.
---

diff --git a/src/code/class.lisp b/src/code/class.lisp
index 8905c34..b6c435c 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -880,7 +880,7 @@
     (%ensure-classoid-valid class2 layout2)))
 
 (defun update-object-layout-or-invalid (object layout)
-  (if (typep (classoid-of object) 'standard-classoid)
+  (if (layout-for-std-class-p (layout-of object))
       (sb!pcl::check-wrapper-validity object)
       (sb!c::%layout-invalid-error object layout)))
 
diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 1775314..b36c483 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -521,28 +521,25 @@
   (/nohexstr obj)
   (/nohexstr layout)
   (when (layout-invalid layout)
-    (error "An obsolete structure accessor function was called."))
+    (error "An obsolete structure typecheck function was called."))
   (/noshow0 "back from testing LAYOUT-INVALID LAYOUT")
   (and (%instancep obj)
        (let ((obj-layout (%instance-layout obj)))
-         (cond ((eq obj-layout layout)
-                ;; (In this case OBJ-LAYOUT can't be invalid, because
-                ;; we determined LAYOUT is valid in the test above.)
-                (/noshow0 "EQ case")
-                t)
-               ((layout-invalid obj-layout)
-                (/noshow0 "LAYOUT-INVALID case")
-                (error 'layout-invalid
-                       :expected-type (layout-classoid layout)
-                       :datum obj))
-               (t
-                (let ((depthoid (layout-depthoid layout)))
-                  (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..")
-                  (/nohexstr depthoid)
-                  (/nohexstr layout-inherits)
-                  (and (> (layout-depthoid obj-layout) depthoid)
-                       (eq (svref (layout-inherits obj-layout) depthoid)
-                           layout))))))))
+         (when (eq obj-layout layout)
+           ;; (In this case OBJ-LAYOUT can't be invalid, because
+           ;; we determined LAYOUT is valid in the test above.)
+           (/noshow0 "EQ case")
+           (return-from typep-to-layout t))
+         (when (layout-invalid obj-layout)
+           (/noshow0 "LAYOUT-INVALID case")
+           (setf obj-layout (update-object-layout-or-invalid obj layout)))
+         (let ((depthoid (layout-depthoid layout)))
+           (/noshow0 "DEPTHOID case, DEPTHOID,LAYOUT-INHERITS=..")
+           (/nohexstr depthoid)
+           (/nohexstr layout-inherits)
+           (and (> (layout-depthoid obj-layout) depthoid)
+                (eq (svref (layout-inherits obj-layout) depthoid)
+                    layout))))))
 
 ;;;; checking structure types
 
diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp
index d7e804e..35ad695 100644
--- a/src/pcl/wrapper.lisp
+++ b/src/pcl/wrapper.lisp
@@ -153,7 +153,7 @@
     (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
+;;; FIXME: This is not a good name: part of the contract 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)
diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 1947bbd..5e5ed66 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -1112,3 +1112,12 @@ redefinition."
     (assert (eq t (boa-supplied-p.2-bar b2)))
     (assert (eq nil (boa-supplied-p.2-barp b1)))
     (assert (eq t (boa-supplied-p.2-barp b2)))))
+
+(defstruct structure-with-predicate)
+(defclass class-to-be-redefined () ())
+(let ((x (make-instance 'class-to-be-redefined)))
+  (defun function-trampoline (fun) (funcall fun x)))
+
+(with-test (:name (:struct-predicate :obsolete-instance))
+  (defclass class-to-be-redefined () ((a :initarg :a :initform 1)))
+  (function-trampoline #'structure-with-predicate-p))