X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/1224dfb0bfbd3a4dfa062cd56ae9f72c960d8e1a..944bf9362ff51217b1617f85126d26e821b8aa91:/src/class-output.lisp diff --git a/src/class-output.lisp b/src/class-output.lisp index a975ebe..45a4909 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -28,35 +28,191 @@ ;;;-------------------------------------------------------------------------- ;;; Walking the layout tree. -(defmethod hook-output progn ((class sod-class) reason sequencer) +(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)) (dolist (method effective-methods) (hook-output method reason sequencer)) (dolist (vtable vtables) (hook-output vtable reason sequencer)))) -(defmethod hook-output progn ((ilayout ilayout) 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 progn ((ichain 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 progn ((islots islots) 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 progn ((vtable vtable) 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 progn ((vtmsgs vtmsgs) 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)))) ;;;-------------------------------------------------------------------------- -;;; Classes. - -(defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer) +;;; Class declarations. + +(export 'emit-class-typedef) +(defgeneric emit-class-typedef (class stream) + (:documentation + "Emit a `typedef' for the CLASS's C class type to the output STREAM. + + By default, this will be an alias for the class's home `ichain' + structure.")) +(defmethod emit-class-typedef ((class sod-class) stream) + (format stream "typedef struct ~A ~A;~%" + (ichain-struct-tag class (sod-class-chain-head class)) class)) + +(export 'emit-class-object-decl) +(defgeneric emit-class-object-decl (class stream) + (:documentation + "Emit the declaration and macros for the CLASS's class object. + + This includes the main declaration, and the convenience macros for + referring to the class object's individual chains. Write everything to + the output STREAM.")) +(defmethod emit-class-object-decl ((class sod-class) stream) + (let ((metaclass (sod-class-metaclass class)) + (metaroot (find-root-metaclass class))) + + ;; Output the actual class object declaration, and the special + ;; `...__class' macro for the root-metaclass chain. + (format stream "/* The class object. */~@ + extern const struct ~A ~A__classobj;~@ + #define ~:*~A__class (&~:*~A__classobj.~A.~A)~%" + (ilayout-struct-tag metaclass) class + (sod-class-nickname (sod-class-chain-head metaroot)) + (sod-class-nickname metaroot)) + + ;; Write the uglier `...__cls_...' macros for the class object's other + ;; chains, if any. + (dolist (chain (sod-class-chains metaclass)) + (let ((tail (car chain))) + (unless (eq tail metaroot) + (format stream "#define ~A__cls_~A (&~2:*~A__classobj.~A.~A)~%" + class (sod-class-nickname (sod-class-chain-head tail)) + (sod-class-nickname tail))))) + (terpri stream))) + +(export 'emit-class-conversion-macro) +(defgeneric emit-class-conversion-macro (class super stream) + (:documentation + "Emit a macro for converting an instance of CLASS to an instance of SUPER. + + By default this is named `CLASS__CONV_SPR'. In-chain upcasts are just a + trivial pointer cast, which any decent compiler will elide; cross-chain + upcasts use the `SOD_XCHAIN' macro. Write the macro to the output + STREAM.")) +(defmethod emit-class-conversion-macro + ((class sod-class) (super sod-class) stream) + (let ((super-head (sod-class-chain-head super))) + (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~ + ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%" + class (sod-class-nickname super) super + (eq super-head (sod-class-chain-head class)) + (sod-class-nickname super-head)))) + +(export 'emit-message-macro-defn) +(defgeneric emit-message-macro-defn + (class entry varargsp me in-names out-names stream) + (:documentation + "Output a message macro for invoking a method ENTRY, with given arguments. + + The default method on `emit-message-macro' calcualates the necessary + argument lists and calls this function to actually write the necessary + `#define' line to the stream. The intended division of responsibilities + is that `emit-message-macro' handles the peculiarities of marshalling the + arguments to the method entry function, while `emit-message-macro-defn' + concerns itself with navigating the vtable to find the right function in + the first place.") + (:method :around ((class sod-class) (entry method-entry) + varargsp me in-names out-names + stream) + (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%")) + (call-next-method) + (when varargsp (format stream "#endif~%")))) +(defmethod emit-message-macro-defn ((class sod-class) (entry method-entry) + varargsp me in-names out-names + stream) + (format stream "#define ~A(~{~A~^, ~}) (~A)->_vt->~A.~A(~{~A~^, ~})~%" + (message-macro-name class entry) + in-names + me + (sod-class-nickname class) + (method-entry-slot-name entry) + out-names)) + +(export 'emit-message-macro) +(defgeneric emit-message-macro (class entry stream) + (:documentation + "Write a macro for invoking the method ENTRY on an instance of CLASS. + + The default behaviour is quite complicated, particular when varargs or + keyword messages are involved.")) +(defmethod emit-message-macro ((class sod-class) (entry method-entry) stream) + (when (some (lambda (message) + (or (keyword-message-p message) + (varargs-message-p message))) + (sod-class-messages class))) + (let* ((type (method-entry-function-type entry)) + (args (c-function-arguments type)) + (in-names nil) (out-names nil) (varargsp nil) (me "me")) + (do ((args args (cdr args))) + ((endp args)) + (let* ((raw-name (princ-to-string (argument-name (car args)))) + (name (if (find raw-name + (list "_vt" + (sod-class-nickname class) + (method-entry-slot-name entry)) + :test #'string=) + (format nil "sod__a_~A" raw-name) + raw-name))) + (cond ((and (cdr args) (eq (cadr args) :ellipsis)) + (setf varargsp t) + (unless in-names (setf me "SOD__CAR(__VA_ARGS__)")) + (push (format nil "/*~A*/ ..." name) in-names) + (push "__VA_ARGS__" out-names) + (return)) + (t + (push name in-names) + (push name out-names))))) + (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%")) + (emit-message-macro-defn class entry varargsp me + (nreverse in-names) + (nreverse out-names) + stream) + (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) @@ -68,7 +224,8 @@ (class :vtmsgs :start) (class :vtmsgs :end) (class :vtables :start) (class :vtables :end) (class :vtable-externs) (class :vtable-externs-after) - (class :methods :start) (class :methods) (class :methods :end) + (class :methods :start) (class :methods :defs) + (class :methods) (class :methods :end) (class :ichains :start) (class :ichains :end) (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end) (class :conversions) @@ -76,32 +233,14 @@ (class :object) (:classes :end)) - (:typedefs - (format stream "typedef struct ~A ~A;~%" - (ichain-struct-tag class (sod-class-chain-head class)) class)) - - ((class :banner) - (banner (format nil "Class ~A" class) stream)) - ((class :vtable-externs-after) - (terpri stream)) - - ((class :vtable-externs) - (format stream "/* Vtable structures. */~%")) - - ((class :object) - (let ((metaclass (sod-class-metaclass class)) - (metaroot (find-root-metaclass class))) - (format stream "/* The class object. */~@ - extern const struct ~A ~A__classobj;~@ - #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%" - (ilayout-struct-tag metaclass) class - (sod-class-nickname (sod-class-chain-head metaroot)) - (sod-class-nickname metaroot))))) + (:typedefs (emit-class-typedef class stream)) + ((class :banner) (banner (format nil "Class ~A" class) stream)) + ((class :vtable-externs-after) (terpri stream)) + ((class :vtable-externs) (format stream "/* Vtable structures. */~%")) + ((class :object) (emit-class-object-decl class stream))) ;; Maybe generate an islots structure. (when (sod-class-slots class) - (dolist (slot (sod-class-slots class)) - (hook-output slot 'islots sequencer)) (sequence-output (stream sequencer) ((class :islots :start) (format stream "/* Instance slots. */~@ @@ -122,16 +261,10 @@ (when (sod-class-direct-superclasses class) (sequence-output (stream sequencer) ((class :conversions) - (let ((chain-head (sod-class-chain-head class))) - (format stream "/* Conversion macros. */~%") - (dolist (super (cdr (sod-class-precedence-list class))) - (let ((super-head (sod-class-chain-head super))) - (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~ - ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%" - class (sod-class-nickname super) super - (eq chain-head super-head) - (sod-class-nickname super-head)))) - (terpri stream))))) + (format stream "/* Conversion macros. */~%") + (dolist (super (cdr (sod-class-precedence-list class))) + (emit-class-conversion-macro class super stream)) + (terpri stream)))) ;; Provide convenience macros for sending the newly defined messages. (The ;; macros work on all subclasses too.) @@ -139,6 +272,14 @@ ;; We need each message's method entry type for this, so we need to dig it ;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains ;; entries for precisely the messages we want to make macros for. + (when (some (lambda (message) + (or (keyword-message-p message) + (varargs-message-p message))) + (sod-class-messages class)) + (one-off-output 'varargs-macros sequencer :early-decls + (lambda (stream) + (format stream + "~%SOD__VARARGS_MACROS_PREAMBLE~%")))) (when (sod-class-messages class) (sequence-output (stream sequencer) ((class :message-macros) @@ -151,57 +292,35 @@ (vtable-body vtable)))) (format stream "/* Message invocation macros. */~%") (dolist (entry (vtmsgs-entries vtmsgs)) - (let* ((type (method-entry-function-type entry)) - (args (c-function-arguments type)) - (in-names nil) (out-names nil) (varargsp nil) (me "me")) - (do ((args args (cdr args))) - ((endp args)) - (let* ((raw-name (princ-to-string (argument-name (car args)))) - (name (if (find raw-name - (list "_vt" - (sod-class-nickname class) - (method-entry-slot-name entry)) - :test #'string=) - (format nil "sod__a_~A" raw-name) - raw-name))) - (cond ((and (cdr args) (eq (cadr args) :ellipsis)) - (setf varargsp t) - (unless in-names (setf me "SOD__CAR(__VA_ARGS__)")) - (push (format nil "/*~A*/ ..." name) in-names) - (push "__VA_ARGS__" out-names) - (return)) - (t - (push name in-names) - (push name out-names))))) - (when varargsp - (format stream "#if __STDC_VERSION__ >= 199901~%")) - (format stream "#define ~A(~{~A~^, ~}) ~ - ~A->_vt->~A.~A(~{~A~^, ~})~%" - (message-macro-name class entry) - (nreverse in-names) - me - (sod-class-nickname class) - (method-entry-slot-name entry) - (nreverse out-names)) - (when varargsp - (format stream "#endif~%")))) - (terpri stream))))) - - ;; Generate vtmsgs structure for all superclasses. + (emit-message-macro class entry stream)) + (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)) + (hook-output slot 'islots sequencer)) + + ;; Generate a vtmsgs structure for all superclasses. (hook-output (car (sod-class-vtables class)) 'vtmsgs sequencer)) ;;;-------------------------------------------------------------------------- ;;; Instance structure. -(defmethod hook-output progn - ((slot sod-slot) (reason (eql 'islots)) sequencer) +(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 ";") (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot))) (terpri stream)))) -(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer) +(defmethod hook-output ((ilayout ilayout) (reason (eql :h)) sequencer) + "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) @@ -209,11 +328,22 @@ struct ~A {~%" (ilayout-struct-tag class))) ((class :ilayout :end) - (format stream "};~2%"))) - (dolist (ichain ichains) - (hook-output ichain 'ilayout sequencer)))) + (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. -(defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer) + 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) @@ -242,8 +372,8 @@ (sod-class-nickname super))) (sod-class-chain chain-tail)))))))) -(defmethod hook-output progn - ((ichain ichain) (reason (eql 'ilayout)) sequencer) +(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) @@ -251,28 +381,35 @@ (ichain-union-tag chain-tail chain-head) (sod-class-nickname chain-head)))))) -(defmethod hook-output progn ((vtptr vtable-pointer) - (reason (eql :h)) - sequencer) +(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 - (sequence-output (stream sequencer) - ((class :ichain chain-head :slots) - (format stream " const struct ~A *_vt;~%" - (vtable-struct-tag chain-tail chain-head)))))) + (when (eq class chain-tail) + (sequence-output (stream sequencer) + ((class :ichain chain-head :slots) + (format stream " const struct ~A *_vt;~%" + (vtable-struct-tag chain-tail chain-head))))))) -(defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer) +(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 - (sequence-output (stream sequencer) - ((subclass :ichain (sod-class-chain-head class) :slots) - (format stream " struct ~A ~A;~%" - (islots-struct-tag class) - (sod-class-nickname class)))))) + (let ((head (sod-class-chain-head class))) + (when (eq head (sod-class-chain-head subclass)) + (sequence-output (stream sequencer) + ((subclass :ichain (sod-class-chain-head class) :slots) + (format stream " struct ~A ~A;~%" + (islots-struct-tag class) + (sod-class-nickname class)))))))) ;;;-------------------------------------------------------------------------- ;;; Vtable structure. -(defmethod hook-output progn - ((method sod-method) (reason (eql :h)) sequencer) +(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) @@ -280,9 +417,24 @@ (princ "extern " stream) (pprint-c-type (commentify-function-type type) stream (sod-method-function-name method)) - (format stream ";~%")))))) - -(defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer) + (format stream ";~%"))) + ((class :methods :defs) + (let* ((type (sod-method-type method)) + (keys (and (typep type 'c-keyword-function-type) + (c-function-keywords type)))) + (when keys + (format stream "struct ~A {~%~ + ~{ unsigned ~A: 1;~%~}~ + };~2%" + (direct-method-suppliedp-struct-tag method) + (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) @@ -315,16 +467,18 @@ (vtable-union-tag chain-tail chain-head) (vtable-name class chain-head)))))) -(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer) +(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 - (sequence-output (stream sequencer) - ((subclass :vtable chain-head :slots) - (format stream " struct ~A ~A;~%" - (vtmsgs-struct-tag subclass class) - (sod-class-nickname class)))))) + (when (eq subclass chain-tail) + (sequence-output (stream sequencer) + ((subclass :vtable chain-head :slots) + (format stream " struct ~A ~A;~%" + (vtmsgs-struct-tag subclass class) + (sod-class-nickname class))))))) -(defmethod hook-output progn - ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) sequencer) +(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) @@ -341,8 +495,9 @@ ((subclass :vtmsgs class :end) (format stream "};~2%")))))) -(defmethod hook-output progn - ((entry method-entry) (reason (eql 'vtmsgs)) sequencer) +(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)) @@ -355,35 +510,39 @@ (pprint-c-type pointer-type stream (method-entry-slot-name entry))) (terpri stream))))) -(defmethod hook-output progn - ((cptr class-pointer) (reason (eql :h)) sequencer) +(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 - (sequence-output (stream sequencer) - ((class :vtable chain-head :slots) - (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%" - metaclass - (and (sod-class-direct-superclasses meta-chain-head) - (sod-class-nickname meta-chain-head))))))) - -(defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer) + (when (eq chain-head (sod-class-chain-head class)) + (sequence-output (stream sequencer) + ((class :vtable chain-head :slots) + (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%" + metaclass + (and (sod-class-direct-superclasses meta-chain-head) + (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 - (sequence-output (stream sequencer) - ((class :vtable chain-head :slots) - (write-line " size_t _base;" stream))))) + (when (eq chain-head (sod-class-chain-head class)) + (sequence-output (stream sequencer) + ((class :vtable chain-head :slots) + (write-line " size_t _base;" stream)))))) -(defmethod hook-output progn - ((choff chain-offset) (reason (eql :h)) sequencer) +(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 - (sequence-output (stream sequencer) - ((class :vtable chain-head :slots) - (format stream " ptrdiff_t _off_~A;~%" - (sod-class-nickname target-head)))))) + (when (eq chain-head (sod-class-chain-head class)) + (sequence-output (stream sequencer) + ((class :vtable chain-head :slots) + (format stream " ptrdiff_t _off_~A;~%" + (sod-class-nickname target-head))))))) ;;;-------------------------------------------------------------------------- ;;; 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 @@ -393,7 +552,22 @@ It may be bound at other times.") -(defmethod hook-output progn ((class sod-class) (reason (eql :c)) sequencer) +(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 @@ -415,8 +589,10 @@ const struct ~A ~A__classobj = {~%" (ilayout-struct-tag (sod-class-metaclass class)) class)) ((class :object :end) - (format stream "};~2%"))) + (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))) @@ -424,8 +600,9 @@ const struct ~A ~A__classobj = {~%" ;;;-------------------------------------------------------------------------- ;;; Direct and effective methods. -(defmethod hook-output progn - ((method delegating-direct-method) (reason (eql :c)) sequencer) +(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)) @@ -436,19 +613,30 @@ const struct ~A ~A__classobj = {~%" (c-function-arguments (sod-method-next-method-type method))))) ((class :direct-method method :end) - (format stream "#undef CALL_NEXT_METHOD~%"))))) + (format stream "#undef CALL_NEXT_METHOD~%")))) + (call-next-method)) -(defmethod hook-output progn - ((method sod-method) (reason (eql :c)) sequencer) - (with-slots ((class %class) body) 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)) (sequence-output (stream sequencer) :constraint ((class :direct-methods :start) + (class :direct-method method :banner) (class :direct-method method :start) (class :direct-method method :body) (class :direct-method method :end) (class :direct-methods :end)) + ((class :direct-method method :banner) + (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~ + on `~A.~A' ~:_defined by `~A'." + role + (sod-class-nickname + (sod-message-class message)) + (sod-message-name message) + class) + (fresh-line stream)) ((class :direct-method method :body) (pprint-c-type (sod-method-function-type method) stream @@ -459,18 +647,44 @@ const struct ~A ~A__classobj = {~%" ((class :direct-method method :end) (terpri stream))))) -(defmethod hook-output progn - ((method basic-effective-method) (reason (eql :c)) sequencer) +(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) + (let* ((keys (effective-method-keywords method)) + (message (effective-method-message method)) + (msg-class (sod-message-class message))) + (when keys + (format-banner-comment stream "Keyword argument structure ~:_~ + for `~A.~A' ~:_on class `~A'." + (sod-class-nickname msg-class) + (sod-message-name message) + class) + (format stream "~&struct ~A {~%" + (effective-method-keyword-struct-tag method)) + (format stream "~{ unsigned ~A__suppliedp: 1;~%~}" + (mapcar #'argument-name keys)) + (dolist (key keys) + (write-string " " stream) + (pprint-c-type (argument-type key) stream (argument-name key)) + (format stream ";~%")) + (format stream "};~2%"))) (dolist (func functions) (write func :stream stream :escape nil :circle nil)))))) ;;;-------------------------------------------------------------------------- ;;; Vtables. -(defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer) +(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) @@ -486,8 +700,8 @@ const struct ~A ~A__classobj = {~%" ((class :vtable chain-head :end) (format stream "} };~2%"))))) -(defmethod hook-output progn - ((cptr class-pointer) (reason (eql :c)) sequencer) +(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) @@ -503,7 +717,8 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname meta-chain-head) (sod-class-nickname metaclass)))))) -(defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer) +(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) @@ -515,8 +730,8 @@ const struct ~A ~A__classobj = {~%" (ilayout-struct-tag class) (sod-class-nickname chain-head)))))) -(defmethod hook-output progn - ((choff chain-offset) (reason (eql :c)) sequencer) +(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) @@ -529,7 +744,11 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname chain-head) (sod-class-nickname target-head)))))) -(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer) +(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) @@ -543,8 +762,8 @@ const struct ~A ~A__classobj = {~%" ((subclass :vtable chain-head :vtmsgs class :end) (format stream " },~%"))))) -(defmethod hook-output progn - ((entry method-entry) (reason (eql :c)) sequencer) +(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)) @@ -558,8 +777,11 @@ const struct ~A ~A__classobj = {~%" ;;;-------------------------------------------------------------------------- ;;; Filling in the class object. -(defmethod hook-output progn - ((ichain ichain) (reason (eql 'class)) sequencer) +(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) @@ -572,8 +794,11 @@ const struct ~A ~A__classobj = {~%" ((*instance-class* :object chain-head :ichain :end) (format stream " } },~%"))))) -(defmethod hook-output progn - ((islots islots) (reason (eql 'class)) sequencer) +(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) @@ -587,8 +812,9 @@ const struct ~A ~A__classobj = {~%" ((*instance-class* :object class :slots :end) (format stream " },~%")))))) -(defmethod hook-output progn - ((vtptr vtable-pointer) (reason (eql 'class)) sequencer) +(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) @@ -600,17 +826,12 @@ const struct ~A ~A__classobj = {~%" (vtable-name class chain-head) (sod-class-nickname chain-tail)))))) -(defgeneric find-class-initializer (slot class) - (:method ((slot effective-slot) (class sod-class)) - (let ((dslot (effective-slot-direct-slot slot))) - (or (some (lambda (super) - (find dslot (sod-class-class-initializers super) - :test #'sod-initializer-slot)) - (sod-class-precedence-list class)) - (effective-slot-initializer slot))))) - (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 @@ -619,27 +840,28 @@ 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))) - (ecase (sod-initializer-value-kind init) - (:simple (format stream " /* ~15@A = */ ~A,~%" - (sod-slot-name direct-slot) - (sod-initializer-value-form init))) - (:compound (format stream " /* ~15@A = */ ~@<{ ~;~A~; },~:>~%" - (sod-slot-name direct-slot) - (sod-initializer-value-form init))))))) - -(defmethod hook-output progn - ((slot sod-class-effective-slot) (reason (eql 'class)) sequencer) + (format stream " /* ~15@A = */ ~A,~%" + (sod-slot-name direct-slot) + (sod-initializer-value init))))) + +(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 (sequence-output (stream sequencer) ((instance :object :prepare) - (funcall func instance stream)))))) + (funcall func instance stream))))) + (call-next-method)) -(defmethod hook-output progn - ((slot effective-slot) (reason (eql 'class)) sequencer) +(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)))