X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fdefstruct.lisp;h=12571a12fd187d60f985881c8ce778dfe66d793d;hb=72db452798256d266d5909bd330d9eb5b31c6f1e;hp=89a8b9c569dc851ac916460068c80b02ec0fd9cf;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 89a8b9c..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))
@@ -931,14 +940,17 @@
 ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities
 (defun %compiler-set-up-layout (dd
                                 &optional
-                                ;; Several special cases (STRUCTURE-OBJECT
-                                ;; itself, and structures with alternate
-                                ;; metaclasses) call this function directly,
-                                ;; and they're all at the base of the
-                                ;; instance class structure, so this is
-                                ;; a handy default.
-                                (inherits (vector (find-layout t)
-                                                  (find-layout 'instance))))
+                                ;; Several special cases
+                                ;; (STRUCTURE-OBJECT itself, and
+                                ;; structures with alternate
+                                ;; metaclasses) call this function
+                                ;; directly, and they're all at the
+                                ;; base of the instance class
+                                ;; structure, so this is a handy
+                                ;; default.  (But note
+                                ;; FUNCALLABLE-STRUCTUREs need
+                                ;; assistance here)
+                                (inherits (vector (find-layout t))))
 
   (multiple-value-bind (classoid layout old-layout)
       (multiple-value-bind (clayout clayout-p)
@@ -1506,11 +1518,13 @@
   (let* ((dd (make-defstruct-description class-name))
          (conc-name (concatenate 'string (symbol-name class-name) "-"))
          (dd-slots (let ((reversed-result nil)
-                         ;; The index starts at 1 for ordinary
-                         ;; named slots because slot 0 is
-                         ;; magical, used for LAYOUT in
-                         ;; CONDITIONs or for something (?) in
-                         ;; funcallable instances.
+                         ;; The index starts at 1 for ordinary named
+                         ;; slots because slot 0 is magical, used for
+                         ;; the LAYOUT in CONDITIONs and
+                         ;; FUNCALLABLE-INSTANCEs.  (This is the same
+                         ;; in ordinary structures too: see (INCF
+                         ;; DD-LENGTH) in
+                         ;; PARSE-DEFSTRUCT-NAME-AND-OPTIONS).
                          (index 1))
                      (dolist (slot-name slot-names)
                        (push (make-defstruct-slot-description
@@ -1520,6 +1534,15 @@
                              reversed-result)
                        (incf index))
                      (nreverse reversed-result))))
+    (case dd-type
+      ;; We don't support inheritance of alternate metaclass stuff,
+      ;; and it's not a general-purpose facility, so sanity check our
+      ;; own code.
+      (structure
+       (aver (eq superclass-name 't)))
+      (funcallable-structure
+       (aver (eq superclass-name 'function)))
+      (t (bug "Unknown DD-TYPE in ALTERNATE-METACLASS: ~S" dd-type)))
     (setf (dd-alternate-metaclass dd) (list superclass-name
                                             metaclass-name
                                             metaclass-constructor)
@@ -1569,13 +1592,16 @@
                       ,object-gensym)
                    '%instance-ref))
           (funcallable-structure
-           (values `(%make-funcallable-instance ,dd-length
-                                                ,delayed-layout-form)
+           (values `(let ((,object-gensym
+                           (%make-funcallable-instance ,dd-length)))
+                      (setf (%funcallable-instance-layout ,object-gensym)
+                            ,delayed-layout-form)
+                      ,object-gensym)
                    '%funcallable-instance-info)))
       `(progn
 
          (eval-when (:compile-toplevel :load-toplevel :execute)
-           (%compiler-set-up-layout ',dd))
+           (%compiler-set-up-layout ',dd ',(inherits-for-structure dd)))
 
          ;; slot readers and writers
          (declaim (inline ,@(mapcar #'dsd-accessor-name dd-slots)))
@@ -1639,7 +1665,7 @@
      ;; Note: This has an ALTERNATE-METACLASS only because of blind
      ;; clueless imitation of the CMU CL code -- dunno if or why it's
      ;; needed. -- WHN
-     (dd-alternate-metaclass dd) '(instance)
+     (dd-alternate-metaclass dd) '(t)
      (dd-slots dd) nil
      (dd-length dd) 1
      (dd-type dd) 'structure)