X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=12571a12fd187d60f985881c8ce778dfe66d793d;hb=72db452798256d266d5909bd330d9eb5b31c6f1e;hp=5ba663c4640d79b40e887d920412d0308ae0c91d;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 5ba663c..12571a1 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -360,7 +360,7 @@
                 ;; class.
                 (with-single-package-locked-error
                     (:symbol ',name "defining ~A as a structure"))
-                (%defstruct ',dd ',inherits)
+                (%defstruct ',dd ',inherits (sb!c:source-location))
                 (eval-when (:compile-toplevel :load-toplevel :execute)
                   (%compiler-defstruct ',dd ',inherits))
                 ,@(unless expanding-into-code-for-xc-host-p
@@ -376,11 +376,17 @@
                   (:symbol ',name "defining ~A as a structure"))
               (eval-when (:compile-toplevel :load-toplevel :execute)
                 (setf (info :typed-structure :info ',name) ',dd))
+              (eval-when (:load-toplevel :execute)
+                (setf (info :source-location :typed-structure ',name)
+                      (sb!c:source-location)))
               ,@(unless expanding-into-code-for-xc-host-p
                   (append (typed-accessor-definitions dd)
                           (typed-predicate-definitions dd)
                           (typed-copier-definitions dd)
-                          (constructor-definitions dd)))
+                          (constructor-definitions dd)
+                          (when (dd-doc dd)
+                            `((setf (fdocumentation ',(dd-name dd) 'structure)
+                               ',(dd-doc dd))))))
               ',name)))))
 
 (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
@@ -858,7 +864,7 @@
 ;;; incompatible redefinition. Define those functions which are
 ;;; sufficiently stereotyped that we can implement them as standard
 ;;; closures.
-(defun %defstruct (dd inherits)
+(defun %defstruct (dd inherits source-location)
   (declare (type defstruct-description dd))
 
   ;; We set up LAYOUTs even in the cross-compilation host.
@@ -878,6 +884,9 @@
            (setq layout (classoid-layout classoid))))
     (setf (find-classoid (dd-name dd)) classoid)
 
+    (sb!c:with-source-location (source-location)
+      (setf (layout-source-location layout) source-location))
+
     ;; Various other operations only make sense on the target SBCL.
     #-sb-xc-host
     (%target-defstruct dd layout))