`((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)
;; 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
(: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)
;;; 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.
(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))
(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)
(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-p))
+
+ (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))