(defun output-imprint-function (class stream)
(let ((ilayout (sod-class-ilayout class)))
(format stream "~&~:
+/* Imprint raw memory with instance structure. */
static void *~A__imprint(void *p)
{
struct ~A *sod__obj = p;
- ~:{sod__obj.~A._vt = &~A;~:^~% ~}
+ ~:{sod__obj.~A.~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))))
+ (let* ((head (ichain-head ichain))
+ (tail (ichain-tail ichain)))
+ (list (sod-class-nickname head)
+ (sod-class-nickname tail)
+ (vtable-name class head))))
(ilayout-ichains ilayout)))))
(defun output-init-function (class stream)
class
(ilayout-struct-tag class))
(dolist (ichain (ilayout-ichains ilayout))
- (let ((ich (format nil "sod__obj.~A"
- (sod-class-nickname (ichain-head ichain)))))
+ (let ((ich (format nil "sod__obj.~A.~A"
+ (sod-class-nickname (ichain-head ichain))
+ (sod-class-nickname (ichain-tail ichain)))))
(dolist (item (ichain-body ichain))
(etypecase item
(vtable-pointer
(ecase (sod-initializer-value-kind init)
(:single
(format stream " ~A = ~A;~%"
- isl (sod-initializer-value-form slot)))
+ isl (sod-initializer-value-form init)))
(:compound
(format stream " ~A = (~A)~A;~%"
isl (sod-slot-type dslot)
- (sod-initializer-value-form slot)))))))))))))
+ (sod-initializer-value-form init)))))))))))))
(format stream "~&~:
return (p);
}~2%")))
(let ((supers (sod-class-direct-superclasses class)))
(when supers
(format stream "~&~:
+/* Direct superclasses. */
static const SodClass *const ~A__supers[] = {
~{~A__class~^,~% ~}
};~2%"
(defun output-cpl-vector (class stream)
(format stream "~&~:
+/* Class precedence list. */
static const SodClass *const ~A__cpl[] = {
~{~A__class~^,~% ~}
};~2%"
(defun output-chains-vector (class stream)
(let ((chains (sod-class-chains class)))
(format stream "~&~:
+/* Chain structure. */
~1@*~:{static const SodClass *const ~A__chain_~A[] = {
-~{ ~A__class~^,~%~}
+ ~{~A__class~^,~% ~}
};~:^~2%~}
~0@*static const struct sod_chain ~A__chains[] = {
of the information (name, type, and how to initialize them) about these
slots in one place, so that's what we do here."))
+(defclass sod-magic-class-initializer (sod-class-initializer)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader sod-initializer-function)
+ (prepare-function :initarg :prepare-function
+ :type (or symbol function)
+ :reader sod-initializer-prepare-function)))
+
(defmethod shared-initialize :after
((slot sod-class-slot) slot-names &key pset)
(declare (ignore slot-names))
(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
(make-instance 'sod-class-effective-slot
- :slot slot
+ :class class :slot slot
:initializer-function (sod-slot-initializer-function slot)
:prepare-function (sod-slot-prepare-function slot)
:initializer (find-slot-initializer class slot)))
(format nil "sizeof(struct ~A)"
(ilayout-struct-tag class))))
("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
- :prepare-function 'output-imprint-function
+ :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
+ :prepare-function output-init-function
:initializer-function
,(lambda (class)
(format nil "~A__init" class)))
,(lambda (class)
(length (sod-class-direct-superclasses class))))
("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
- :prepare-function 'output-supers-vector
+ :prepare-function output-supers-vector
:initializer-function
,(lambda (class)
(if (sod-class-direct-superclasses class)
,(lambda (class)
(length (sod-class-precedence-list class))))
("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
- :prepare-function 'output-cpl-vector
+ :prepare-function output-cpl-vector
:initializer-function
,(lambda (class)
(format nil "~A__cpl" class)))
,(lambda (class)
(length (sod-class-chains class))))
("chains" ,(c-type (* (struct "sod_chain" :const)))
- :prepare-function 'output-chains-vector
+ :prepare-function output-chains-vector
:initializer-function
,(lambda (class)
(format nil "~A__chains" class)))