+;;;
+;;; FIXME: This is a daft place for this function. It's also accumulating
+;;; all of the magic associated with initializing class instances.
+
+(defun output-imprint-function (class stream)
+ (let ((ilayout (sod-class-ilayout class)))
+ (format stream "~&~:
+static void *~A__imprint(void *p)
+{
+ struct ~A *sod__obj = p;
+
+ ~:{sod__obj.~A._vt = &~A;~:^~% ~}
+ return (p);
+}~2%"
+ class
+ (ilayout-struct-tag class)
+ (mapcar (lambda (ichain)
+ (list (sod-class-nickname (ichain-head ichain))
+ (vtable-name class (ichain-head ichain))))
+ (ilayout-ichains ilayout)))))
+
+(defun output-init-function (class stream)
+ ;; FIXME this needs a metaobject protocol
+ (let ((ilayout (sod-class-ilayout class)))
+ (format stream "~&~:
+static void *~A__init(void *p)
+{
+ struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
+ class
+ (ilayout-struct-tag class))
+ (dolist (ichain (ilayout-ichains ilayout))
+ (let ((ich (format nil "sod__obj.~A"
+ (sod-class-nickname (ichain-head ichain)))))
+ (dolist (item (ichain-body ichain))
+ (etypecase item
+ (vtable-pointer
+ (format stream " ~A._vt = &~A;~%"
+ ich (vtable-name class (ichain-head ichain))))
+ (islots
+ (let ((isl (format nil "~A.~A"
+ ich
+ (sod-class-nickname (islots-class item)))))
+ (dolist (slot (islots-slots item))
+ (let ((dslot (effective-slot-direct-slot slot))
+ (init (effective-slot-initializer slot)))
+ (when init
+ (ecase (sod-initializer-value-kind init)
+ (:single
+ (format stream " ~A = ~A;~%"
+ isl (sod-initializer-value-form slot)))
+ (:compound
+ (format stream " ~A = (~A)~A;~%"
+ isl (sod-slot-type dslot)
+ (sod-initializer-value-form slot)))))))))))))
+ (format stream "~&~:
+ return (p);
+}~2%")))
+
+(defun output-supers-vector (class stream)
+ (let ((supers (sod-class-direct-superclasses class)))
+ (when supers
+ (format stream "~&~:
+static const SodClass *const ~A__supers[] = {
+ ~{~A__class~^,~% ~}
+};~2%"
+ class supers))))
+
+(defun output-cpl-vector (class stream)
+ (format stream "~&~:
+static const SodClass *const ~A__cpl[] = {
+ ~{~A__class~^,~% ~}
+};~2%"
+ class (sod-class-precedence-list class)))
+
+(defun output-chains-vector (class stream)
+ (let ((chains (sod-class-chains class)))
+ (format stream "~&~:
+~1@*~:{static const SodClass *const ~A__chain_~A[] = {
+~{ ~A__class~^,~%~}
+};~:^~2%~}
+
+~0@*static const struct sod_chain ~A__chains[] = {
+~:{ { ~3@*~A,
+ ~0@*&~A__chain_~A,
+ ~4@*offsetof(struct ~A, ~A),
+ (const struct sod_vtable *)&~A,
+ sizeof(struct ~A) }~:^,~%~}
+};~2%"
+ class ;0
+ (mapcar (lambda (chain) ;1
+ (let* ((head (sod-class-chain-head (car chain)))
+ (chain-nick (sod-class-nickname head)))
+ (list class chain-nick ;0 1
+ (reverse chain) ;2
+ (length chain) ;3
+ (ilayout-struct-tag class) chain-nick ;4 5
+ (vtable-name class head) ;6
+ (ichain-struct-tag class head)))) ;7
+ chains))))
+
+(defparameter *sod-class-slots*
+ `(
+
+ ;; Basic informtion.
+ ("name" ,(c-type const-string)
+ :initializer-function
+ ,(lambda (class)
+ (prin1-to-string (sod-class-name class))))
+ ("nick" ,(c-type const-string)
+ :initializer-function
+ ,(lambda (class)
+ (prin1-to-string (sod-class-nickname class))))
+
+ ;; Instance allocation and initialization.
+ ("instsz" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (format nil "sizeof(struct ~A)"
+ (ilayout-struct-tag class))))
+ ("imprint" ,(c-type (* (fun (* void) ("p" (* void)))))
+ :prepare-function 'output-imprint-function
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__imprint" class)))
+ ("init" ,(c-type (* (fun (* void) ("p" (* void)))))
+ :prepare-function 'output-init-function
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__init" class)))
+
+ ;; Superclass structure.
+ ("n_supers" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (length (sod-class-direct-superclasses class))))
+ ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
+ :prepare-function 'output-supers-vector
+ :initializer-function
+ ,(lambda (class)
+ (if (sod-class-direct-superclasses class)
+ (format nil "~A__supers" class)
+ 0)))
+ ("n_cpl" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (length (sod-class-precedence-list class))))
+ ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
+ :prepare-function 'output-cpl-vector
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__cpl" class)))
+
+ ;; Chain structure.
+ ("link" ,(c-type (* (class "SodClass" :const)))
+ :initializer-function
+ ,(lambda (class)
+ (let ((link (sod-class-chain-link class)))
+ (if link
+ (format nil "~A__class" link)
+ 0))))
+ ("head" ,(c-type (* (class "SodClass" :const)))
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__class" (sod-class-chain-head class))))
+ ("level" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (position class (reverse (sod-class-chain class)))))
+ ("n_chains" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (length (sod-class-chains class))))
+ ("chains" ,(c-type (* (struct "sod_chain" :const)))
+ :prepare-function 'output-chains-vector
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__chains" class)))
+
+ ;; Class-specific layout.
+ ("off_islots" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (format nil "offsetof(struct ~A, ~A)"
+ (ichain-struct-tag class
+ (sod-class-chain-head class))
+ (sod-class-nickname class))))
+ ("islotsz" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (format nil "sizeof(struct ~A)"
+ (islots-struct-tag class))))))
+
+(defclass sod-class-slot (sod-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader sod-slot-initializer-function)
+ (prepare-function :initarg :prepare-function
+ :type (or symbol function)
+ :reader sod-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on sod_object.
+
+ These slots need class-specific initialization. It's easier to keep all
+ of the information (name, type, and how to initialize them) about these
+ slots in one place, so that's what we do here."))
+
+(defmethod shared-initialize :after
+ ((slot sod-class-slot) slot-names &key pset)
+ (declare (ignore slot-names))
+ (default-slot (slot 'initializer-function)
+ (get-property pset :initializer-function t nil))
+ (default-slot (slot 'prepare-function)
+ (get-property pset :prepare-function t nil)))
+
+(defclass sod-class-effective-slot (effective-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader effective-slot-initializer-function)
+ (prepare-function :initarg :prepare-function
+ :type (or symbol function)
+ :reader effective-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on slot_object.
+
+ This class ignores any explicit initializers and computes initializer
+ values using the slot's INIT-FUNC slot and a magical protocol during
+ metaclass instance construction."))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
+ (make-instance 'sod-class-effective-slot
+ :slot slot
+ :initializer-function (sod-slot-initializer-function slot)
+ :prepare-function (sod-slot-prepare-function slot)
+ :initializer (find-slot-initializer class slot)))