From 4818ff760f1568e90ad9523f4d16c349c954f4cb Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 22 Aug 2019 23:44:07 +0100 Subject: [PATCH] src/class-output.lisp: Split up `hook-output' on `sod-class' and `:h'. Introduce five new generic functions to carry most of the load. The remaining `hook-output' functions all seem simple enough to be replaced as necessary. --- doc/SYMBOLS | 16 ++++ doc/output.tex | 16 ++++ src/class-output.lisp | 213 +++++++++++++++++++++++++++++++++----------------- 3 files changed, 173 insertions(+), 72 deletions(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 0396997..33f497f 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -359,6 +359,11 @@ class-make-proto.lisp class-output.lisp *instance-class* variable + emit-class-conversion-macro generic + emit-class-object-decl generic + emit-class-typedef generic + emit-message-macro generic + emit-message-macro-defn generic class-utilities.lisp argument-lists-compatible-p function @@ -1057,6 +1062,12 @@ effective-slot-initializer-function sod-class-effective-slot effective-slot-prepare-function sod-class-effective-slot +emit-class-conversion-macro + sod-class sod-class t +emit-class-object-decl + sod-class t +emit-class-typedef + sod-class t emit-decl sod::basic-codegen t emit-decls @@ -1066,6 +1077,11 @@ emit-inst emit-insts t t sod::basic-codegen t +emit-message-macro + sod-class method-entry t +emit-message-macro-defn + sod-class method-entry t t t t t + sod-class method-entry t t t t t [:around] ensure-sequencer-item sequencer t ensure-var diff --git a/doc/output.tex b/doc/output.tex index fc59bb4..27826ff 100644 --- a/doc/output.tex +++ b/doc/output.tex @@ -227,6 +227,22 @@ until the third. So the final processing order is \begin{describe}{var}{*instance-class*} \end{describe} +\begin{describe}{gf}{emit-class-typedef @ @} +\end{describe} + +\begin{describe}{gf}{emit-class-object-decl @ @} +\end{describe} + +\begin{describe}{gf}{emit-class-conversion-macro @ @ @} +\end{describe} + +\begin{describe*} + {\dhead{gf}{emit-message-macro @ @ @} + \dhead{gf}{emit-message-macro-defn + \=@ @ @ @ \\ + \>@ @ @}} +\end{describe*} + %% output for `h' files %% %% prologue diff --git a/src/class-output.lisp b/src/class-output.lisp index 49453e9..f2d3e43 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -56,6 +56,137 @@ ;;;-------------------------------------------------------------------------- ;;; 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) ;; Main output sequencing. @@ -77,34 +208,11 @@ (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)~%" - (ilayout-struct-tag metaclass) class - (sod-class-nickname (sod-class-chain-head metaroot)) - (sod-class-nickname metaroot)) - (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)))) + (: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) @@ -128,16 +236,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.) @@ -165,40 +267,7 @@ (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 "#ifdef SOD__HAVE_VARARGS_MACROS~%")) - (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~%")))) + (emit-message-macro class entry stream)) (terpri stream)))))) (defmethod hook-output :after ((class sod-class) (reason (eql :h)) sequencer) -- 2.11.0