X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/4818ff760f1568e90ad9523f4d16c349c954f4cb..12949379840101e2d65883f29c5e8f0f6de49e9c:/src/class-output.lisp diff --git a/src/class-output.lisp b/src/class-output.lisp index f2d3e43..0dfd30a 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -29,6 +29,8 @@ ;;; Walking the layout tree. (defmethod hook-output :after ((class sod-class) reason sequencer) + "Register hooks for the class layout, direct methods, effective methods, + and vtables." (with-slots ((ilayout %ilayout) vtables methods effective-methods) class (hook-output ilayout reason sequencer) (dolist (method methods) (hook-output method reason sequencer)) @@ -36,20 +38,25 @@ (dolist (vtable vtables) (hook-output vtable reason sequencer)))) (defmethod hook-output :after ((ilayout ilayout) reason sequencer) + "Register hooks for the layout's ichains." (with-slots (ichains) ilayout (dolist (ichain ichains) (hook-output ichain reason sequencer)))) (defmethod hook-output :after ((ichain ichain) reason sequencer) + "Register hooks for the ichain body's items." (dolist (item (ichain-body ichain)) (hook-output item reason sequencer))) (defmethod hook-output :after ((islots islots) reason sequencer) + "Register hooks for the islots structure's individual slots." (dolist (slot (islots-slots islots)) (hook-output slot reason sequencer))) (defmethod hook-output :after ((vtable vtable) reason sequencer) + "Register hooks for the vtable body's items." (with-slots (body) vtable (dolist (item body) (hook-output item reason sequencer)))) (defmethod hook-output :after ((vtmsgs vtmsgs) reason sequencer) + "Register hooks for the vtmsgs structure's individual method entries." (with-slots (entries) vtmsgs (dolist (entry entries) (hook-output entry reason sequencer)))) @@ -188,6 +195,24 @@ (when varargsp (format stream "#endif~%")))) (defmethod hook-output ((class sod-class) (reason (eql :h)) sequencer) + "Write the skeleton of a class declaration. + + Most of the work is done by other functions. + + * The class type is defined by `emit-class-typedef'. + + * The class object is declared by `emit-class-object-decl'. + + * The upcast conversion macros are defined by `emit-class-conversion- + macro'. + + * The message invocation macros are defined by `emit-message-macro'. + + * The class instance structure itself is constructed by the `ilayout' + object. + + * The various vtable structures are constructed by the `vtable' + objects." ;; Main output sequencing. (sequence-output (stream sequencer) @@ -271,6 +296,7 @@ (terpri stream)))))) (defmethod hook-output :after ((class sod-class) (reason (eql :h)) sequencer) + "Register hooks to output CLASS's direct slots and messages." ;; Output a structure member definition for each instance slot. (dolist (slot (sod-class-slots class)) @@ -283,6 +309,7 @@ ;;; Instance structure. (defmethod hook-output ((slot sod-slot) (reason (eql 'islots)) sequencer) + "Declare the member for an individual slot within an `islots' structure." (sequence-output (stream sequencer) (((sod-slot-class slot) :islots :slots) (pprint-logical-block (stream nil :prefix " " :suffix ";") @@ -290,7 +317,11 @@ (terpri stream)))) (defmethod hook-output ((ilayout ilayout) (reason (eql :h)) sequencer) - (with-slots ((class %class)) ilayout + "Define the structure for a class layout. + + Here we just provide the outermost structure. It gets filled in by + the `ichains' objects and their body items." + (with-slots ((class %class) ichains) ilayout (sequence-output (stream sequencer) ((class :ilayout :start) (format stream "/* Instance layout. */~@ @@ -300,10 +331,19 @@ (format stream "};~2%"))))) (defmethod hook-output :after ((ilayout ilayout) (reason (eql :h)) sequencer) + "Register hooks to write chain members into the overall class layout." (dolist (ichain (ilayout-ichains ilayout)) (hook-output ichain 'ilayout sequencer))) (defmethod hook-output ((ichain ichain) (reason (eql :h)) sequencer) + "Define the layout structure for a particular chain of a class. + + A member of this class is dropped into the `ilayout' structure by the + corresponding method for the `ilayout' reason. + + We define both the chain structure of the class, and a union of it with + all of its in-chain superclasses (so as to invoke the common-prefix + rule)." (with-slots ((class %class) chain-head chain-tail) ichain (when (eq class chain-tail) (sequence-output (stream sequencer) @@ -333,6 +373,7 @@ (sod-class-chain chain-tail)))))))) (defmethod hook-output ((ichain ichain) (reason (eql 'ilayout)) sequencer) + "Declare the member for a class chain within the class layout." (with-slots ((class %class) chain-head chain-tail) ichain (sequence-output (stream sequencer) ((class :ilayout :slots) @@ -341,6 +382,7 @@ (sod-class-nickname chain-head)))))) (defmethod hook-output ((vtptr vtable-pointer) (reason (eql :h)) sequencer) + "Declare the member for a vtable pointer within an `ichain' structure." (with-slots ((class %class) chain-head chain-tail) vtptr (when (eq class chain-tail) (sequence-output (stream sequencer) @@ -349,6 +391,7 @@ (vtable-struct-tag chain-tail chain-head))))))) (defmethod hook-output ((islots islots) (reason (eql :h)) sequencer) + "Declare the member for a class's `islots' within an `ichain' structure." (with-slots ((class %class) subclass slots) islots (let ((head (sod-class-chain-head class))) (when (eq head (sod-class-chain-head subclass)) @@ -362,6 +405,11 @@ ;;; Vtable structure. (defmethod hook-output ((method sod-method) (reason (eql :h)) sequencer) + "Emit declarations for a direct method. + + We declare the direct method function, and, if necessary, the `suppliedp' + structure for its keyword arguments." + (with-slots ((class %class)) method (sequence-output (stream sequencer) ((class :methods) @@ -382,6 +430,11 @@ (mapcar #'argument-name keys)))))))) (defmethod hook-output ((vtable vtable) (reason (eql :h)) sequencer) + "Define the structure for a vtable. + + We define the vtable structure of the class, and a union of it with all of + its in-chain superclasses (so as to invoke the common-prefix rule). We + also declare the vtable object, defined by the corresponding `:c' method." (with-slots ((class %class) chain-head chain-tail) vtable (when (eq class chain-tail) (sequence-output (stream sequencer) @@ -415,6 +468,7 @@ (vtable-name class chain-head)))))) (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :h)) sequencer) + "Declare the member for a class's `vtmsgs' within a `vtable' structure." (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs (when (eq subclass chain-tail) (sequence-output (stream sequencer) @@ -424,6 +478,7 @@ (sod-class-nickname class))))))) (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer) + "Define the `vtmsgs' structure for a class's method entry functions." (when (vtmsgs-entries vtmsgs) (with-slots ((class %class) subclass) vtmsgs (sequence-output (stream sequencer) @@ -442,6 +497,7 @@ (defmethod hook-output ((entry method-entry) (reason (eql 'vtmsgs)) sequencer) + "Declare the member for a method entry within a `vtmsgs' structure." (let* ((method (method-entry-effective-method entry)) (message (effective-method-message method)) (class (effective-method-class method)) @@ -455,6 +511,7 @@ (terpri stream))))) (defmethod hook-output ((cptr class-pointer) (reason (eql :h)) sequencer) + "Declare the member for a class-chain pointer within a `vtmsgs' structure." (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr (when (eq chain-head (sod-class-chain-head class)) (sequence-output (stream sequencer) @@ -465,6 +522,7 @@ (sod-class-nickname meta-chain-head)))))))) (defmethod hook-output ((boff base-offset) (reason (eql :h)) sequencer) + "Declare the member for the base offset within a `vtmsgs' structure." (with-slots ((class %class) chain-head) boff (when (eq chain-head (sod-class-chain-head class)) (sequence-output (stream sequencer) @@ -472,6 +530,7 @@ (write-line " size_t _base;" stream)))))) (defmethod hook-output ((choff chain-offset) (reason (eql :h)) sequencer) + "Declare the member for a cross-chain offset within a `vtmsgs' structure." (with-slots ((class %class) chain-head target-head) choff (when (eq chain-head (sod-class-chain-head class)) (sequence-output (stream sequencer) @@ -480,10 +539,45 @@ (sod-class-nickname target-head))))))) ;;;-------------------------------------------------------------------------- +;;; Static instance declarations. + +(export 'declare-static-instance) +(defgeneric declare-static-instance (instance stream) + (:documentation + "Write a declaration for the static INSTANCE to STREAM. + + Note that, according to whether the instance is external or private, this + may be written as part of the `:h' or `:c' reasons.")) +(defmethod declare-static-instance (instance stream) + (with-slots ((class %class) name externp constp) instance + (format stream "~:[static~;extern~] ~:[~;const ~]struct ~ + ~A ~A__instance;~%~ + #define ~A (&~A__instance.~A.~A)~%" + externp constp (ilayout-struct-tag class) name + name name (sod-class-nickname (sod-class-chain-head class)) + (sod-class-nickname class)))) + +(defmethod hook-output + ((instance static-instance) (reason (eql :h)) sequencer) + "Write an `extern' declaration for an external static instance." + (with-slots (externp) instance + (when externp + (one-off-output 'static-instances-banner sequencer + '(:static-instances :start) + (lambda (stream) + (banner "Public static instances" stream))) + (one-off-output 'static-instances-end sequencer + '(:static-instances :end) + #'terpri) + (sequence-output (stream sequencer) + (:static-instances + (declare-static-instance instance stream)))))) + +;;;-------------------------------------------------------------------------- ;;; Implementation output. (export '*instance-class*) -(defvar *instance-class* nil +(defvar-unbound *instance-class* "The class currently being output. This is bound during the `hook-output' traversal of a class layout for @@ -494,6 +588,21 @@ It may be bound at other times.") (defmethod hook-output ((class sod-class) (reason (eql :c)) sequencer) + "Write the skeleton of a class definition. + + Most of the work is done by other methods. + + * The direct methods are defined by the `sod-method' objects. + + * The effective method functions and related structures are defined by + the effective method objects. + + * The vtable structures are initialized by the vtable objects and their + component items. + + * The class structure and its associated tables are initialized by the + metaclass's layout objects." + (sequence-output (stream sequencer) :constraint @@ -518,6 +627,7 @@ const struct ~A ~A__classobj = {~%" (format stream "};~2%")))) (defmethod hook-output :after ((class sod-class) (reason (eql :c)) sequencer) + "Register hooks to initialize the class object structure." (let ((*instance-class* class)) (hook-output (sod-class-ilayout (sod-class-metaclass class)) 'class sequencer))) @@ -527,6 +637,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output ((method delegating-direct-method) (reason (eql :c)) sequencer) + "Define the `CALL_NEXT_METHOD' macro around a `delegating-direct-method'." (with-slots ((class %class) body) method (unless body (return-from hook-output)) @@ -541,6 +652,7 @@ const struct ~A ~A__classobj = {~%" (call-next-method)) (defmethod hook-output ((method sod-method) (reason (eql :c)) sequencer) + "Define a direct method function." (with-slots ((class %class) role body message) method (unless body (return-from hook-output)) @@ -572,6 +684,10 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output ((method basic-effective-method) (reason (eql :c)) sequencer) + "Define an effective method's functions. + + Specifically, the method-entry functions and any auxiliary functions + needed to stitch everything together." (with-slots ((class %class) functions) method (sequence-output (stream sequencer) ((class :effective-methods) @@ -600,6 +716,10 @@ const struct ~A ~A__classobj = {~%" ;;; Vtables. (defmethod hook-output ((vtable vtable) (reason (eql :c)) sequencer) + "Define a vtable structure. + + Here we just provide the outermost structure. It gets filled in by the + vtable object's body items." (with-slots ((class %class) chain-head chain-tail) vtable (sequence-output (stream sequencer) :constraint ((class :vtables :start) @@ -616,6 +736,7 @@ const struct ~A ~A__classobj = {~%" (format stream "} };~2%"))))) (defmethod hook-output ((cptr class-pointer) (reason (eql :c)) sequencer) + "Drop a class pointer into a vtable definition." (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) @@ -632,6 +753,7 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname metaclass)))))) (defmethod hook-output ((boff base-offset) (reason (eql :c)) sequencer) + "Drop a base offset into a vtable definition." (with-slots ((class %class) chain-head) boff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) @@ -644,6 +766,7 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname chain-head)))))) (defmethod hook-output ((choff chain-offset) (reason (eql :c)) sequencer) + "Drop a cross-chain offset into a vtable definition." (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) @@ -657,6 +780,10 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname target-head)))))) (defmethod hook-output ((vtmsgs vtmsgs) (reason (eql :c)) sequencer) + "Define the method entry pointers for a superclass's messages. + + We only provide the outer structure. It gets filled in by the + `method-entry' objects." (with-slots ((class %class) subclass chain-head) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtable chain-head :start) @@ -671,6 +798,7 @@ const struct ~A ~A__classobj = {~%" (format stream " },~%"))))) (defmethod hook-output ((entry method-entry) (reason (eql :c)) sequencer) + "Define a method-entry pointer in a vtable." (with-slots ((method %method) chain-head chain-tail role) entry (let* ((message (effective-method-message method)) (class (effective-method-class method)) @@ -685,6 +813,10 @@ const struct ~A ~A__classobj = {~%" ;;; Filling in the class object. (defmethod hook-output ((ichain ichain) (reason (eql 'class)) sequencer) + "Define an instance chain of a class object. + + Here we only provide the outer structure. It gets filled in by the + `ichain' object's body items." (with-slots ((class %class) chain-head) ichain (sequence-output (stream sequencer) :constraint ((*instance-class* :object :start) @@ -698,6 +830,10 @@ const struct ~A ~A__classobj = {~%" (format stream " } },~%"))))) (defmethod hook-output ((islots islots) (reason (eql 'class)) sequencer) + "Define an instance's slots in a class object. + + Here we only provide the outer structure. It gets filled in by the + individual slot objects." (with-slots ((class %class)) islots (let ((chain-head (sod-class-chain-head class))) (sequence-output (stream sequencer) @@ -713,6 +849,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output ((vtptr vtable-pointer) (reason (eql 'class)) sequencer) + "Define a vtable pointer in a class object." (with-slots ((class %class) chain-head chain-tail) vtptr (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) @@ -725,7 +862,11 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname chain-tail)))))) (defgeneric output-class-initializer (slot instance stream) + (:documentation + "Define an individual slot in a class object.") (:method ((slot sod-class-effective-slot) (instance sod-class) stream) + "If this slot has an initializer function, then call it; otherwise try to + find an initializer as usual." (let ((func (effective-slot-initializer-function slot)) (direct-slot (effective-slot-direct-slot slot))) (if func @@ -734,6 +875,7 @@ const struct ~A ~A__classobj = {~%" (funcall func instance)) (call-next-method)))) (:method ((slot effective-slot) (instance sod-class) stream) + "Initialize a class slot by looking up an applicable initializer." (let ((init (find-class-initializer slot instance)) (direct-slot (effective-slot-direct-slot slot))) (format stream " /* ~15@A = */ ~A,~%" @@ -742,6 +884,8 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output ((slot sod-class-effective-slot) (reason (eql 'class)) sequencer) + "Write any necessary preparatory definitions for a class slot with a + computed initializer." (let ((instance *instance-class*) (func (effective-slot-prepare-function slot))) (when func @@ -752,6 +896,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output ((slot effective-slot) (reason (eql 'class)) sequencer) + "Define a slot in a class object." (with-slots ((class %class) (dslot slot)) slot (let ((instance *instance-class*) (super (sod-slot-class dslot))) @@ -759,4 +904,134 @@ const struct ~A ~A__classobj = {~%" ((instance :object super :slots) (output-class-initializer slot instance stream)))))) +;;;-------------------------------------------------------------------------- +;;; Static instances. + +(export '*static-instance*) +(defvar-unbound *static-instance* + "The static instance currently being output. + + This is bound during the `hook-output' traversal of a static instance for + `:c', since the slots traversed need to be able to look up initializers + from the static instance definition.") + +(defmethod hook-output ((instance static-instance) + (reason (eql :c)) sequencer) + "Write a static instance definition." + (with-slots (externp) instance + (one-off-output 'static-instances-banner sequencer + '(:static-instances :start) + (lambda (stream) + (banner "Static instance definitions" stream))) + (unless externp + (one-off-output 'static-instances-forward sequencer + '(:static-instances :start) + (lambda (stream) + (format stream "/* Forward declarations. */~%"))) + (one-off-output 'static-instances-forward-gap sequencer + '(:static-instances :gap) + #'terpri) + (sequence-output (stream sequencer) + ((:static-instances :decls) + (declare-static-instance instance stream)))))) + +(defmethod hook-output ((class sod-class) + (reason (eql 'static-instance)) sequencer) + "Output the framing around a static instance initializer." + (let ((instance *static-instance*)) + (with-slots ((class %class) name externp constp) instance + (sequence-output (stream sequencer) + :constraint ((:static-instances :gap) + (*static-instance* :start) + (*static-instance* :end) + (:static-instances :end)) + ((*static-instance* :start) + (format stream "/* Static instance `~A'. */~%~ + ~:[static ~;~]~:[~;const ~]~ + struct ~A ~A__instance = {~%" + name + externp constp + (ilayout-struct-tag class) name)) + ((*static-instance* :end) + (format stream "};~2%")))))) + +(defmethod hook-output ((ichain ichain) + (reason (eql 'static-instance)) sequencer) + "Output the initializer for an ichain." + (with-slots ((class %class) chain-head chain-tail) ichain + (sequence-output (stream sequencer) + :constraint ((*static-instance* :start) + (*static-instance* :ichain chain-head :start) + (*static-instance* :ichain chain-head :end) + (*static-instance* :end)) + ((*static-instance* :ichain chain-head :start) + (format stream " { { /* ~A ichain */~%" + (sod-class-nickname chain-head))) + ((*static-instance* :ichain chain-head :end) + (format stream " } },~%"))))) + +(defmethod hook-output ((islots islots) + (reason (eql 'static-instance)) sequencer) + "Initialize a static instance's slots." + (with-slots ((class %class)) islots + (let ((chain-head (sod-class-chain-head class))) + (sequence-output (stream sequencer) + :constraint + ((*static-instance* :ichain chain-head :start) + (*static-instance* :slots class :start) + (*static-instance* :slots class) + (*static-instance* :slots class :end) + (*static-instance* :ichain chain-head :end)) + ((*static-instance* :slots class :start) + (format stream " { /* Class ~A */~%" class)) + ((*static-instance* :slots class :end) + (format stream " },~%")))))) + +(defmethod hook-output ((vtptr vtable-pointer) + (reason (eql 'static-instance)) sequencer) + "Initialize a vtable pointer in a static instance.." + (with-slots ((class %class) chain-head chain-tail) vtptr + (sequence-output (stream sequencer) + :constraint ((*static-instance* :ichain chain-head :start) + (*static-instance* :vtable chain-head) + (*static-instance* :ichain chain-head :end)) + ((*static-instance* :vtable chain-head) + (format stream " /* ~17@A = */ &~A.~A,~%" + "_vt" + (vtable-name class chain-head) + (sod-class-nickname chain-tail)))))) + +(export 'output-static-instance-initializer) +(defgeneric output-static-instance-initializer (instance slot stream) + (:documentation + "Output an initializer for an effective SLOT in a static INSTANCE.")) +(defmethod output-static-instance-initializer ((instance static-instance) + (slot effective-slot) + stream) + (let* ((direct-slot (effective-slot-direct-slot slot)) + (init (or (find direct-slot + (static-instance-initializers instance) + :key #'sod-initializer-slot) + (effective-slot-initializer slot)))) + (format stream " /* ~15@A = */ ~A,~%" + (sod-slot-name direct-slot) + (sod-initializer-value init)))) + +(defmethod hook-output ((slot effective-slot) + (reason (eql 'static-instance)) sequencer) + "Initialize a slot in a static instance." + (with-slots ((class %class) initializers) *static-instance* + (with-slots ((dslot slot)) slot + (let ((super (sod-slot-class dslot)) + (instance *static-instance*)) + (sequence-output (stream sequencer) + ((instance :slots super) + (output-static-instance-initializer instance slot stream))))))) + +(defmethod hook-output :after + ((instance static-instance) (reason (eql :c)) sequencer) + (with-slots ((class %class)) instance + (let ((*static-instance* instance)) + (hook-output class 'static-instance sequencer)))) + ;;;----- That's all, folks --------------------------------------------------