X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Ftarget-defstruct.lisp;h=e9b5b607102bd4c2f669320a5aee58e97580c8fb;hb=670010e3f3dcd62efaf23f61abdc73950edb88c6;hp=ec62457e1f717d326ada263b8a7d1fc6d802083e;hpb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;p=sbcl.git

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index ec62457..e9b5b60 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -142,6 +142,10 @@
 
 ;;;; 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))
 
@@ -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)