0.8.18.14:

[sbcl.git] / src / code / target-defstruct.lisp

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index c463637..33dc00d 100644 (file)
--- 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)))
@@ -422,7 +439,7 @@
           (pprint-pop)
           (let ((slot (pop remaining-slots)))
             (write-char #\: stream)
-            (output-symbol-name (dsd-%name slot) stream)
+            (output-symbol-name (symbol-name (dsd-name slot)) stream)
             (write-char #\space stream)
             (pprint-newline :miser stream)
             (output-object (funcall (fdefinition (dsd-accessor-name slot))
@@ -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)
@@ -452,7 +474,7 @@
        (write-char #\space stream)
        (write-char #\: stream)
        (let ((slot (first remaining-slots)))
-         (output-symbol-name (dsd-%name slot) stream)
+         (output-symbol-name (symbol-name (dsd-name slot)) stream)
          (write-char #\space stream)
          (output-object
           (funcall (fdefinition (dsd-accessor-name slot))