0.8alpha.0.41:

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

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 858e452..bad8d95 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=..")
@@ -177,19 +181,22 @@
   (dolist (dsd (dd-slots dd))
     (/show0 "doing FDEFINITION for slot accessor")
     (let ((accessor-name (dsd-accessor-name dsd)))
-      (/show0 "ACCESSOR-NAME=..")
-      (/hexstr accessor-name)
-      (protect-cl accessor-name)
-      (/hexstr "getting READER-FUN and WRITER-FUN")
-      (multiple-value-bind (reader-fun writer-fun) (slot-accessor-funs dd dsd)
-       (declare (type function reader-fun writer-fun))
-       (/show0 "got READER-FUN and WRITER-FUN=..")
-       (/hexstr reader-fun)
-       (setf (symbol-function accessor-name) reader-fun)
-       (unless (dsd-read-only dsd)
-         (/show0 "setting FDEFINITION for WRITER-FUN=..")
-         (/hexstr writer-fun)
-         (setf (fdefinition `(setf ,accessor-name)) writer-fun)))))
+      ;; We mustn't step on any inherited accessors
+      (unless (accessor-inherited-data accessor-name dd)
+       (/show0 "ACCESSOR-NAME=..")
+       (/hexstr accessor-name)
+       (protect-cl accessor-name)
+       (/hexstr "getting READER-FUN and WRITER-FUN")
+       (multiple-value-bind (reader-fun writer-fun)
+           (slot-accessor-funs dd dsd)
+         (declare (type function reader-fun writer-fun))
+         (/show0 "got READER-FUN and WRITER-FUN=..")
+         (/hexstr reader-fun)
+         (setf (symbol-function accessor-name) reader-fun)
+         (unless (dsd-read-only dsd)
+           (/show0 "setting FDEFINITION for WRITER-FUN=..")
+           (/hexstr writer-fun)
+           (setf (fdefinition `(setf ,accessor-name)) writer-fun))))))
 
   ;; Set FDEFINITION for copier.
   (when (dd-copier-name dd)
@@ -233,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
@@ -383,12 +395,21 @@
 
     res))
 \f
-;;; default PRINT-OBJECT and MAKE-LOAD-FORM methods
+;;; default PRINT-OBJECT method
 
 (defun %default-structure-pretty-print (structure stream)
   (let* ((layout (%instance-layout structure))
-        (name (sb!xc:class-name (layout-class layout)))
+        (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)))
@@ -401,7 +422,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))
@@ -413,7 +434,7 @@
             (pprint-newline :linear stream))))))))
 (defun %default-structure-ugly-print (structure stream)
   (let* ((layout (%instance-layout structure))
-        (name (sb!xc:class-name (layout-class layout)))
+        (name (classoid-name (layout-classoid layout)))
         (dd (layout-info layout)))
     (descend-into (stream)
       (write-string "#S(" stream)
@@ -431,7 +452,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))
@@ -447,12 +468,6 @@
         (%default-structure-ugly-print structure stream))))
 (def!method print-object ((x structure-object) stream)
   (default-structure-print x stream *current-level-in-print*))
-
-(defun make-load-form-saving-slots (object &key slot-names environment)
-  (declare (ignore object environment))
-  (if slot-names
-      (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE
-      :sb-just-dump-it-normally))
 \f
 ;;;; testing structure types
 
@@ -487,7 +502,7 @@
               ((layout-invalid obj-layout)
                (/noshow0 "LAYOUT-INVALID case")
                (error 'layout-invalid
-                      :expected-type (layout-class obj-layout)
+                      :expected-type (layout-classoid obj-layout)
                       :datum obj))
               (t
                (let ((depthoid (layout-depthoid layout)))
@@ -514,7 +529,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)
@@ -529,7 +544,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)
@@ -549,7 +564,7 @@
   (unless (typep-to-layout x layout)
     (error 'type-error
           :datum x
-          :expected-type (class-name (layout-class layout))))
+          :expected-type (classoid-name (layout-classoid layout))))
   (values))
 \f
 (/show0 "target-defstruct.lisp end of file")