X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-defstruct.lisp;h=33dc00d359210c34b90d164375e78e22af8b05f8;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=bad8d9554e6265b4a97a2e442a0cfa751c8b13bc;hpb=8af1983e6de2609fec800b6ac2bf3b12ff9c68b9;p=sbcl.git

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index bad8d95..33dc00d 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -321,13 +321,21 @@
 	     ;; through here.
 	     (%slotplace-accessor-funs (slotplace instance-type-check-form)
 	       (/show "macroexpanding %SLOTPLACE-ACCESSOR-FUNS" slotplace instance-type-check-form)
-	       `(values (lambda (instance)
-			  (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
-			  ,instance-type-check-form
-			  (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
-			  ,slotplace)
-			(let ((typecheckfun (typespec-typecheckfun dsd-type)))
-			  (lambda (new-value instance)
+	       `(let ((typecheckfun (typespec-typecheckfun dsd-type)))
+                  (values (if (dsd-safe-p dsd)
+                              (lambda (instance)
+                                (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
+                                ,instance-type-check-form
+                                (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+                                ,slotplace)
+                              (lambda (instance)
+                                (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined reader")
+                                ,instance-type-check-form
+                                (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
+                                (let ((value ,slotplace))
+                                  (funcall typecheckfun value)
+                                  value)))
+                          (lambda (new-value instance)
 			    (/noshow0 "in %SLOTPLACE-ACCESSOR-FUNS-defined writer")
 			    ,instance-type-check-form
 			    (/noshow0 "back from INSTANCE-TYPE-CHECK-FORM")
@@ -337,7 +345,7 @@
 
     (let ((dsd-index (dsd-index dsd))
 	  (dsd-type (dsd-type dsd)))
-	    
+
       #+sb-xc (/show0 "got DSD-TYPE=..")
       #+sb-xc (/hexstr dsd-type)
       (ecase (dd-type dd)
@@ -346,7 +354,7 @@
 	(structure
 	 #+sb-xc (/show0 "case of DSD-TYPE = STRUCTURE")
 	 (%native-slot-accessor-funs %instance-ref))
-				     
+
 	;; structures with the :TYPE option
 
 	;; FIXME: Worry about these later..
@@ -387,8 +395,8 @@
       (when raw-index
 	(let* ((data (%instance-ref structure raw-index))
 	       (raw-len (length data))
-	       (new (make-array raw-len :element-type '(unsigned-byte 32))))
-	  (declare (type (simple-array (unsigned-byte 32) (*)) data))
+	       (new (make-array raw-len :element-type 'sb!vm::word)))
+	  (declare (type (simple-array sb!vm::word (*)) data))
 	  (setf (%instance-ref res raw-index) new)
 	  (dotimes (i raw-len)
 	    (setf (aref new i) (aref data i))))))
@@ -410,6 +418,15 @@
 	(write-char #\space stream)
 	(write-string "(no LAYOUT-INFO)"))
       (return-from %default-structure-pretty-print nil))
+    ;; the structure type doesn't count as a component for
+    ;; *PRINT-LEVEL* processing.  We can likewise elide the logical
+    ;; block processing, since all we have to print is the type name.
+    ;; -- CSR, 2004-10-05
+    (when (and dd (null (dd-slots dd)))
+      (write-string "#S(" stream)
+      (prin1 name stream)
+      (write-char #\) stream)
+      (return-from %default-structure-pretty-print nil))
     (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
       (prin1 name stream)
       (let ((remaining-slots (dd-slots dd)))
@@ -436,6 +453,11 @@
   (let* ((layout (%instance-layout structure))
 	 (name (classoid-name (layout-classoid layout)))
 	 (dd (layout-info layout)))
+    (when (and dd (null (dd-slots dd)))
+      (write-string "#S(" stream)
+      (prin1 name stream)
+      (write-char #\) stream)
+      (return-from %default-structure-ugly-print nil))
     (descend-into (stream)
       (write-string "#S(" stream)
       (prin1 name stream)