X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefstruct.lisp;h=995a12fefe30546a039395e2106879a0f4a098e4;hb=447477e72bd4fe54e678a28bdcc4a2802797d6ed;hp=5b6004d85aaa43e320b68d06e819ef34b9661a52;hpb=34664ac9b1d27f0dff2514c388cf10813a9b1108;p=sbcl.git

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 5b6004d..995a12f 100644
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -333,7 +333,8 @@
               `((setf (structure-classoid-constructor (find-classoid ',name))
                       #',def-con))))))))
 
-;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
+;;; shared logic for host macroexpansion for SB!XC:DEFSTRUCT and
+;;; cross-compiler macroexpansion for CL:DEFSTRUCT
 (defmacro !expander-for-defstruct (name-and-options
                                    slot-descriptions
                                    expanding-into-code-for-xc-host-p)
@@ -360,7 +361,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 +377,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 +865,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 +885,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))
@@ -941,8 +951,7 @@
                                 ;; default.  (But note
                                 ;; FUNCALLABLE-STRUCTUREs need
                                 ;; assistance here)
-                                (inherits (vector (find-layout t)
-                                                  (find-layout 'instance))))
+                                (inherits (vector (find-layout t))))
 
   (multiple-value-bind (classoid layout old-layout)
       (multiple-value-bind (clayout clayout-p)
@@ -1150,7 +1159,7 @@
                                    (lambda (x)
                                      (sb!xc:typep x 'structure-classoid))
                                    (lambda (x)
-                                     (sb!xc:typep x (find-classoid class))))
+                                     (sb!xc:typep x (classoid-name (find-classoid class)))))
                                (fdefinition constructor)))
     (setf (classoid-direct-superclasses class)
           (case (dd-name info)
@@ -1531,9 +1540,9 @@
       ;; and it's not a general-purpose facility, so sanity check our
       ;; own code.
       (structure
-       (aver (eq superclass-name 'instance)))
+       (aver (eq superclass-name 't)))
       (funcallable-structure
-       (aver (eq superclass-name 'funcallable-instance)))
+       (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
@@ -1543,6 +1552,47 @@
           (dd-type dd) dd-type)
     dd))
 
+;;; make !DEFSTRUCT-WITH-ALTERNATE-METACLASS compilable by the host
+;;; lisp, installing the information we need to reason about the
+;;; structures (layouts and classoids).
+;;;
+;;; FIXME: we should share the parsing and the DD construction between
+;;; this and the cross-compiler version, but my brain was too small to
+;;; get that right.  -- CSR, 2006-09-14
+#+sb-xc-host
+(defmacro !defstruct-with-alternate-metaclass
+    (class-name &key
+                (slot-names (missing-arg))
+                (boa-constructor (missing-arg))
+                (superclass-name (missing-arg))
+                (metaclass-name (missing-arg))
+                (metaclass-constructor (missing-arg))
+                (dd-type (missing-arg))
+                predicate
+                (runtime-type-checks-p t))
+
+  (declare (type (and list (not null)) slot-names))
+  (declare (type (and symbol (not null))
+                 boa-constructor
+                 superclass-name
+                 metaclass-name
+                 metaclass-constructor))
+  (declare (type symbol predicate))
+  (declare (type (member structure funcallable-structure) dd-type))
+  (declare (ignore boa-constructor predicate runtime-type-checks))
+
+  (let* ((dd (make-dd-with-alternate-metaclass
+              :class-name class-name
+              :slot-names slot-names
+              :superclass-name superclass-name
+              :metaclass-name metaclass-name
+              :metaclass-constructor metaclass-constructor
+              :dd-type dd-type)))
+    `(progn
+
+      (eval-when (:compile-toplevel :load-toplevel :execute)
+        (%compiler-set-up-layout ',dd ',(inherits-for-structure dd))))))
+
 (sb!xc:defmacro !defstruct-with-alternate-metaclass
     (class-name &key
                 (slot-names (missing-arg))
@@ -1657,7 +1707,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)