;; 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)
;;; 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))
;; 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)
;; 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
;; 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)