X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=4df84792685a41efead2ae89b0ff5d34d8bd720f;hb=0dcc957ae6bf24809fda82fd59c134e70058c42a;hp=92932cf70dfffde206afe3e1959486bc08304f70;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 92932cf..4df8479 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -8,6 +8,8 @@
 ;;;; files for more information.
 
 (in-package "SB!KERNEL")
+
+(/show0 "target-defstruct.lisp 12")
 
 ;;;; structure frobbing primitives
 
@@ -209,6 +211,7 @@
 		   (slots (dd-slots dd) (cdr slots)))
 		  ((or (null slots)
 		       (and (not *print-readably*)
+			    *print-length*
 			    (>= index *print-length*)))
 		   (if (null slots)
 		       (write-string ")" stream)
@@ -247,10 +250,7 @@
   ;; FIXME: CMU CL used (%INSTANCEP OBJ) here. Check that
   ;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code.
   (and (typep obj 'instance)
-       (let (;; FIXME: Mightn't there be a slight efficiency improvement
-	     ;; by delaying the binding of DEPTHOID 'til it's needed?
-	     (depthoid (layout-depthoid layout))
-	     (obj-layout (%instance-layout obj)))
+       (let ((obj-layout (%instance-layout obj)))
 	 (cond ((eq obj-layout layout)
 		t)
 	       ;; FIXME: Does the test for LAYOUT-INVALID really belong
@@ -261,9 +261,10 @@
 		       :expected-type (layout-class obj-layout)
 		       :datum obj))
 	       (t
-		(and (> (layout-depthoid obj-layout) depthoid)
-		     (eq (svref (layout-inherits obj-layout) depthoid)
-			 layout)))))))
+                 (let ((depthoid (layout-depthoid layout)))
+                   (and (> (layout-depthoid obj-layout) depthoid)
+                        (eq (svref (layout-inherits obj-layout) depthoid)
+                            layout))))))))
 
 ;;;; implementing structure slot accessors as closures
 
@@ -302,12 +303,7 @@
 	      (unless (structure-test structure)
 		(error 'simple-type-error
 		       :datum structure
-		       ;; FIXME: :EXPECTED-TYPE should be something
-		       ;; comprehensible to the user, not this. Perhaps we
-		       ;; could work backwards from the LAYOUT-CLASS slot to
-		       ;; find something. (Note that all four SIMPLE-TYPE-ERROR
-		       ;; calls in this section have the same disease.)
-		       :expected-type '(satisfies structure-test)
+		       :expected-type (class-name (layout-class layout))
 		       :format-control
 		       "Structure for accessor ~S is not a ~S:~% ~S"
 		       :format-arguments
@@ -339,7 +335,7 @@
 	      (unless (structure-test structure)
 		(error 'simple-type-error
 		       :datum structure
-		       :expected-type '(satisfies structure-test)
+		       :expected-type (class-name (layout-class layout))
 		       :format-control
 		       "The structure for setter ~S is not a ~S:~% ~S"
 		       :format-arguments
@@ -349,7 +345,7 @@
 	      (unless  (typep-test new-value)
 		(error 'simple-type-error
 		       :datum new-value
-		       :expected-type '(satisfies typep-test)
+		       :expected-type (class-name (layout-class layout))
 		       :format-control
 		       "The new value for setter ~S is not a ~S:~% ~S"
 		       :format-arguments
@@ -366,7 +362,7 @@
 	      (unless (structure-test structure)
 		(error 'simple-type-error
 		       :datum structure
-		       :expected-type '(satisfies structure-test)
+		       :expected-type (class-name (layout-class layout))
 		       :format-control
 		       "The structure for setter ~S is not a ~S:~% ~S"
 		       :format-arguments
@@ -376,7 +372,7 @@
 	      (unless  (typep-test new-value)
 		(error 'simple-type-error
 		       :datum new-value
-		       :expected-type '(satisfies typep-test)
+		       :expected-type (class-name (layout-class layout))
 		       :format-control
 		       "The new value for setter ~S is not a ~S:~% ~S"
 		       :format-arguments
@@ -384,3 +380,5 @@
 			     (dsd-type dsd)
 			     new-value))))
 	    (setf (%instance-ref structure (dsd-index dsd)) new-value)))))
+
+(/show0 "target-defstruct.lisp end of file")