X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=89ced391872bce44bc1c1b592af15538bd512786;hb=522a3c95b9b7a044ff0ab8df1ca29460ef2ad3a7;hp=1775314c468d8d1b024b83aafd9db4ee317f9298;hpb=40bea2551744d3cdc05a79a923fbff79a5755845;p=sbcl.git

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 1775314..89ced39 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -361,9 +361,9 @@
   #!+sb-doc
   "Return a copy of STRUCTURE with the same (EQL) slot values."
   (declare (type structure-object structure))
-  (let* ((len (%instance-length structure))
-         (res (%make-instance len))
-         (layout (%instance-layout structure))
+  (let* ((layout (%instance-layout structure))
+         (res (%make-instance (%instance-length structure)))
+         (len (layout-length layout))
          (nuntagged (layout-n-untagged-slots layout)))
 
     (declare (type index len))
@@ -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