0.8alpha.0.9:

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

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index ec62457..e9b5b60 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -142,6 +142,10 @@
 \f
 ;;;; target-only parts of the DEFSTRUCT top level code
 
+;;; A list of hooks designating functions of one argument, the
+;;; classoid, to be called when a defstruct is evaluated.
+(defvar *defstruct-hooks* nil)
+
 ;;; Catch attempts to mess up definitions of symbols in the CL package.
 (defun protect-cl (symbol)
   (/show0 "entering PROTECT-CL, SYMBOL=..")
@@ -236,6 +240,11 @@
     (setf (fdocumentation (dd-name dd) 'type)
          (dd-doc dd)))
 
+  ;; the BOUNDP test here is to get past cold-init.
+  (when (boundp '*defstruct-hooks*)
+    (dolist (fun *defstruct-hooks*)
+      (funcall fun (find-classoid (dd-name dd)))))
+  
   (/show0 "leaving %TARGET-DEFSTRUCT")
   (values))
 \f
@@ -392,6 +401,15 @@
   (let* ((layout (%instance-layout structure))
         (name (classoid-name (layout-classoid layout)))
         (dd (layout-info layout)))
+    ;; KLUDGE: during the build process with SB-SHOW, we can sometimes
+    ;; attempt to print out a PCL object (with null LAYOUT-INFO).
+    #!+sb-show
+    (when (null dd)
+      (pprint-logical-block (stream nil :prefix "#<" :suffix ">")
+       (prin1 name stream)
+       (write-char #\space stream)
+       (write-string "(no LAYOUT-INFO)"))
+      (return-from %default-structure-pretty-print nil))
     (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
       (prin1 name stream)
       (let ((remaining-slots (dd-slots dd)))
@@ -517,7 +535,7 @@
         ,x
         ,(compiler-layout-or-lose class-name)))
       ((vector)
-       (let ((xx (gensym "X")))
+       (with-unique-names (xx)
         `(let ((,xx ,x))
            (declare (type vector ,xx))
            ,@(when (dd-named dd)
@@ -532,7 +550,7 @@
                     :format-arguments (list ',class-name ,xx)))))
            (values))))
       ((list)
-       (let ((xx (gensym "X")))
+       (with-unique-names (xx)
         `(let ((,xx ,x))
            (declare (type list ,xx))
            ,@(when (dd-named dd)