;;; !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)
(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
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)
,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)))
;; 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)