From 7d8d3a165fa725b686d1c89b78179a4d5705d11a Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 22 Aug 2019 13:05:00 +0100 Subject: [PATCH] src/output-proto.lisp, etc. (hook-output): Use standard combination. This will let subclasses selectively override portions of the basic output machinery. The existing implicit traversal is now done via `:after' methods. Existing hook methods which engaged custom traversal have been split out into separate `:after' methods so that they don't get overridden by accident. The main output-class-to-header method (i.e., `hook-output' specialized on `sod-class' and `(eql :h)') is huge and could usefully be split into smaller pieces which can be overridden separately. --- doc/SYMBOLS | 85 ++++++++++++++++---------------- doc/output.tex | 4 +- src/class-output.lisp | 129 ++++++++++++++++++++++++------------------------- src/module-output.lisp | 8 +-- src/output-proto.lisp | 3 +- 5 files changed, 113 insertions(+), 116 deletions(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index fc98f01..0396997 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -1263,47 +1263,50 @@ format-temporary-name guess-metaclass sod-class hook-output - t t t [progn] - base-offset (eql :c) t [progn] - base-offset (eql :h) t [progn] - basic-effective-method (eql :c) t [progn] - chain-offset (eql :c) t [progn] - chain-offset (eql :h) t [progn] - class-pointer (eql :c) t [progn] - class-pointer (eql :h) t [progn] - code-fragment-item t t [progn] - delegating-direct-method (eql :c) t [progn] - effective-slot (eql cl:class) t [progn] - ichain (eql :h) t [progn] - ichain (eql cl:class) t [progn] - ichain (eql ilayout) t [progn] - ichain t t [progn] - ilayout (eql :h) t [progn] - ilayout t t [progn] - islots (eql :h) t [progn] - islots (eql cl:class) t [progn] - islots t t [progn] - method-entry (eql :c) t [progn] - method-entry (eql vtmsgs) t [progn] - module (eql :c) t [progn] - module (eql :h) t [progn] - module t t [progn] - sod-class (eql :c) t [progn] - sod-class (eql :h) t [progn] - sod-class t t [progn] - sod-class-effective-slot (eql cl:class) t [progn] - sod-method (eql :c) t [progn] - sod-method (eql :h) t [progn] - sod-slot (eql islots) t [progn] - vtable (eql :c) t [progn] - vtable (eql :h) t [progn] - vtable t t [progn] - vtable-pointer (eql :h) t [progn] - vtable-pointer (eql cl:class) t [progn] - vtmsgs (eql :c) t [progn] - vtmsgs (eql :h) t [progn] - vtmsgs (eql vtmsgs) t [progn] - vtmsgs t t [progn] + t t t + base-offset (eql :c) t + base-offset (eql :h) t + basic-effective-method (eql :c) t + chain-offset (eql :c) t + chain-offset (eql :h) t + class-pointer (eql :c) t + class-pointer (eql :h) t + code-fragment-item t t + delegating-direct-method (eql :c) t + effective-slot (eql cl:class) t + ichain (eql :h) t + ichain (eql cl:class) t + ichain (eql ilayout) t + ichain t t [:after] + ilayout (eql :h) t [:after] + ilayout (eql :h) t + ilayout t t [:after] + islots (eql :h) t + islots (eql cl:class) t + islots t t [:after] + method-entry (eql :c) t + method-entry (eql vtmsgs) t + module (eql :c) t + module (eql :h) t + module t t [:after] + sod-class (eql :c) t [:after] + sod-class (eql :c) t + sod-class (eql :h) t [:after] + sod-class (eql :h) t + sod-class t t [:after] + sod-class-effective-slot (eql cl:class) t + sod-method (eql :c) t + sod-method (eql :h) t + sod-slot (eql islots) t + vtable (eql :c) t + vtable (eql :h) t + vtable t t [:after] + vtable-pointer (eql :h) t + vtable-pointer (eql cl:class) t + vtmsgs (eql :c) t + vtmsgs (eql :h) t + vtmsgs (eql vtmsgs) t + vtmsgs t t [:after] ichain-body ichain ichain-class diff --git a/doc/output.tex b/doc/output.tex index 5b464ba..fc59bb4 100644 --- a/doc/output.tex +++ b/doc/output.tex @@ -159,9 +159,9 @@ until the third. So the final processing order is {invoke-sequencer-items @ \&rest @} \end{describe} -\begin{describe}{gf}{hook-output progn @ @ @} +\begin{describe}{gf}{hook-output @ @ @} \begin{describe}{meth}{t,t} - {hook-output progn (@ t) (@ t) @} + {hook-output (@ t) (@ t) @} \end{describe} \end{describe} diff --git a/src/class-output.lisp b/src/class-output.lisp index dec1e4e..2fbdda1 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -28,35 +28,35 @@ ;;;-------------------------------------------------------------------------- ;;; Walking the layout tree. -(defmethod hook-output progn ((class sod-class) reason sequencer) +(defmethod hook-output :after ((class sod-class) reason sequencer) (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) (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) (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) (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) (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) (with-slots (entries) vtmsgs (dolist (entry entries) (hook-output entry reason sequencer)))) ;;;-------------------------------------------------------------------------- ;;; Classes. -(defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer) +(defmethod hook-output ((class sod-class) (reason (eql :h)) sequencer) ;; Main output sequencing. (sequence-output (stream sequencer) @@ -108,8 +108,6 @@ ;; 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. */~@ @@ -201,35 +199,42 @@ (nreverse out-names)) (when varargsp (format stream "#endif~%")))) - (terpri stream))))) + (terpri stream)))))) + +(defmethod hook-output :after ((class sod-class) (reason (eql :h)) sequencer) - ;; Generate vtmsgs structure for all superclasses. + ;; 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) (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) - (with-slots ((class %class) ichains) ilayout +(defmethod hook-output ((ilayout ilayout) (reason (eql :h)) sequencer) + (with-slots ((class %class)) ilayout (sequence-output (stream sequencer) ((class :ilayout :start) (format stream "/* Instance layout. */~@ 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) + (dolist (ichain (ilayout-ichains ilayout)) + (hook-output ichain 'ilayout sequencer))) -(defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer) +(defmethod hook-output ((ichain ichain) (reason (eql :h)) sequencer) (with-slots ((class %class) chain-head chain-tail) ichain (when (eq class chain-tail) (sequence-output (stream sequencer) @@ -258,8 +263,7 @@ (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) (with-slots ((class %class) chain-head chain-tail) ichain (sequence-output (stream sequencer) ((class :ilayout :slots) @@ -267,9 +271,7 @@ (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) (with-slots ((class %class) chain-head chain-tail) vtptr (when (eq class chain-tail) (sequence-output (stream sequencer) @@ -277,7 +279,7 @@ (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) (with-slots ((class %class) subclass slots) islots (let ((head (sod-class-chain-head class))) (when (eq head (sod-class-chain-head subclass)) @@ -290,8 +292,7 @@ ;;;-------------------------------------------------------------------------- ;;; Vtable structure. -(defmethod hook-output progn - ((method sod-method) (reason (eql :h)) sequencer) +(defmethod hook-output ((method sod-method) (reason (eql :h)) sequencer) (with-slots ((class %class)) method (sequence-output (stream sequencer) ((class :methods) @@ -311,7 +312,7 @@ (direct-method-suppliedp-struct-tag method) (mapcar #'argument-name keys)))))))) -(defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer) +(defmethod hook-output ((vtable vtable) (reason (eql :h)) sequencer) (with-slots ((class %class) chain-head chain-tail) vtable (when (eq class chain-tail) (sequence-output (stream sequencer) @@ -344,7 +345,7 @@ (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) (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs (when (eq subclass chain-tail) (sequence-output (stream sequencer) @@ -353,8 +354,7 @@ (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) (when (vtmsgs-entries vtmsgs) (with-slots ((class %class) subclass) vtmsgs (sequence-output (stream sequencer) @@ -371,8 +371,8 @@ ((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) (let* ((method (method-entry-effective-method entry)) (message (effective-method-message method)) (class (effective-method-class method)) @@ -385,8 +385,7 @@ (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) (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr (when (eq chain-head (sod-class-chain-head class)) (sequence-output (stream sequencer) @@ -396,15 +395,14 @@ (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) +(defmethod hook-output ((boff base-offset) (reason (eql :h)) sequencer) (with-slots ((class %class) chain-head) boff (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) (with-slots ((class %class) chain-head target-head) choff (when (eq chain-head (sod-class-chain-head class)) (sequence-output (stream sequencer) @@ -426,7 +424,7 @@ 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) (sequence-output (stream sequencer) :constraint @@ -448,8 +446,9 @@ 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) (let ((*instance-class* class)) (hook-output (sod-class-ilayout (sod-class-metaclass class)) 'class sequencer))) @@ -457,8 +456,8 @@ 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) (with-slots ((class %class) body) method (unless body (return-from hook-output)) @@ -469,10 +468,10 @@ 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) +(defmethod hook-output ((method sod-method) (reason (eql :c)) sequencer) (with-slots ((class %class) role body message) method (unless body (return-from hook-output)) @@ -502,8 +501,8 @@ 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) (with-slots ((class %class) functions) method (sequence-output (stream sequencer) ((class :effective-methods) @@ -531,7 +530,7 @@ const struct ~A ~A__classobj = {~%" ;;;-------------------------------------------------------------------------- ;;; Vtables. -(defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer) +(defmethod hook-output ((vtable vtable) (reason (eql :c)) sequencer) (with-slots ((class %class) chain-head chain-tail) vtable (sequence-output (stream sequencer) :constraint ((class :vtables :start) @@ -547,8 +546,7 @@ 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) (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) @@ -564,7 +562,7 @@ 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) (with-slots ((class %class) chain-head) boff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) @@ -576,8 +574,7 @@ 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) (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) @@ -590,7 +587,7 @@ 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) (with-slots ((class %class) subclass chain-head) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtable chain-head :start) @@ -604,8 +601,7 @@ 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) (with-slots ((method %method) chain-head chain-tail role) entry (let* ((message (effective-method-message method)) (class (effective-method-class method)) @@ -619,8 +615,7 @@ 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) (with-slots ((class %class) chain-head) ichain (sequence-output (stream sequencer) :constraint ((*instance-class* :object :start) @@ -633,8 +628,7 @@ 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) (with-slots ((class %class)) islots (let ((chain-head (sod-class-chain-head class))) (sequence-output (stream sequencer) @@ -648,8 +642,8 @@ 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) (with-slots ((class %class) chain-head chain-tail) vtptr (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) @@ -677,17 +671,18 @@ const struct ~A ~A__classobj = {~%" (sod-slot-name direct-slot) (sod-initializer-value init))))) -(defmethod hook-output progn - ((slot sod-class-effective-slot) (reason (eql 'class)) sequencer) +(defmethod hook-output ((slot sod-class-effective-slot) + (reason (eql 'class)) sequencer) (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) (with-slots ((class %class) (dslot slot)) slot (let ((instance *instance-class*) (super (sod-slot-class dslot))) diff --git a/src/module-output.lisp b/src/module-output.lisp index 7895176..90ecb75 100644 --- a/src/module-output.lisp +++ b/src/module-output.lisp @@ -102,13 +102,13 @@ ;;;-------------------------------------------------------------------------- ;;; Output implementation. -(defmethod hook-output progn ((module module) reason sequencer) +(defmethod hook-output :after ((module module) reason sequencer) ;; Ask the module's items to sequence themselves. (dolist (item (module-items module)) (hook-output item reason sequencer))) -(defmethod hook-output progn ((frag code-fragment-item) reason sequencer) +(defmethod hook-output ((frag code-fragment-item) reason sequencer) ;; Output fragments when their reasons are called up. (when (eq reason (code-fragment-reason frag)) @@ -122,7 +122,7 @@ :pretty nil :escape nil)))))) -(defmethod hook-output progn ((module module) (reason (eql :h)) sequencer) +(defmethod hook-output ((module module) (reason (eql :h)) sequencer) (sequence-output (stream sequencer) :constraint @@ -174,7 +174,7 @@ ((:includes :end) (terpri stream)))) -(defmethod hook-output progn ((module module) (reason (eql :c)) sequencer) +(defmethod hook-output ((module module) (reason (eql :c)) sequencer) (sequence-output (stream sequencer) :constraint diff --git a/src/output-proto.lisp b/src/output-proto.lisp index 6a26a7b..e31b201 100644 --- a/src/output-proto.lisp +++ b/src/output-proto.lisp @@ -111,8 +111,7 @@ a reason to its sub-objects that is different from the REASON with which it was itself invoked.") - (:method-combination progn) - (:method progn (object reason sequencer) + (:method (object reason sequencer) (declare (ignore object reason sequencer)))) ;;;-------------------------------------------------------------------------- -- 2.11.0