X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/71ecc48e20c8651175b16f37ee66ca08a36cc1c6..a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa:/class-output.lisp diff --git a/class-output.lisp b/class-output.lisp index ee2daf3..da6531b 100644 --- a/class-output.lisp +++ b/class-output.lisp @@ -93,8 +93,8 @@ (defmethod add-output-hooks progn ((class :object) (let ((metaclass (sod-class-metaclass class)) (metaroot (find-root-metaclass class))) - (format stream "/* The class object. */~%~ - extern const struct ~A ~A__classobj;~%~ + (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)) @@ -106,7 +106,7 @@ (defmethod add-output-hooks progn (add-output-hooks slot 'populate-islots sequencer)) (sequence-output (stream sequencer) ((class :islots :start) - (format stream "/* Instance slots. */~%~ + (format stream "/* Instance slots. */~@ struct ~A {~%" (islots-struct-tag class))) ((class :islots :end) @@ -141,9 +141,11 @@ (defmethod add-output-hooks progn sequencer)) (defmethod add-output-hooks progn ((class sod-class) reason sequencer) - (with-slots (ilayout vtables methods) class + (with-slots (ilayout vtables methods effective-methods) class (add-output-hooks ilayout reason sequencer) (dolist (method methods) (add-output-hooks method reason sequencer)) + (dolist (method effective-methods) + (add-output-hooks method reason sequencer)) (dolist (vtable vtables) (add-output-hooks vtable reason sequencer)))) ;;;-------------------------------------------------------------------------- @@ -166,7 +168,7 @@ (defmethod add-output-hooks progn (with-slots (class ichains) ilayout (sequence-output (stream sequencer) ((class :ilayout :start) - (format stream "/* Instance layout. */~%~ + (format stream "/* Instance layout. */~@ struct ~A {~%" (ilayout-struct-tag class))) ((class :ilayout :end) @@ -185,13 +187,13 @@ (defmethod add-output-hooks progn (class :ichain chain-head :end) (class :ichains :end)) ((class :ichain chain-head :start) - (format stream "/* Instance chain structure. */~%~ + (format stream "/* Instance chain structure. */~@ struct ~A {~%" (ichain-struct-tag chain-tail chain-head))) ((class :ichain chain-head :end) (format stream "};~2%") - (format stream "/* Union of equivalent superclass chains. */~%~ - union ~A {~%~ + (format stream "/* Union of equivalent superclass chains. */~@ + union ~A {~@ ~:{ struct ~A ~A;~%~}~ };~2%" (ichain-union-tag chain-tail chain-head) @@ -259,7 +261,7 @@ (defmethod add-output-hooks progn (class :vtable chain-head :end) (class :vtables :end)) ((class :vtable chain-head :start) - (format stream "/* Vtable structure. */~%~ + (format stream "/* Vtable structure. */~@ struct ~A {~%" (vtable-struct-tag chain-tail chain-head))) ((class :vtable chain-head :end) @@ -290,7 +292,7 @@ (defmethod add-output-hooks progn (subclass :vtmsgs class :end) (subclass :vtmsgs :end)) ((subclass :vtmsgs class :start) - (format stream "/* Messages protocol from class ~A */~%~ + (format stream "/* Messages protocol from class ~A */~@ struct ~A {~%" class (vtmsgs-struct-tag subclass class))) @@ -357,7 +359,7 @@ (defmethod add-output-hooks progn ((:classes :start) (class :banner) (class :direct-methods :start) (class :direct-methods :end) - (class :effective-methods :start) (class :effective-methods :end) + (class :effective-methods) (class :vtables :start) (class :vtables :end) (class :object :prepare) (class :object :start) (class :object :end) (:classes :end)) @@ -382,9 +384,6 @@ (defmethod add-output-hooks progn ;;;-------------------------------------------------------------------------- ;;; Direct methods. -;; This could well want splitting out into some more elaborate protocol. We -;; need a bunch of refactoring anyway. - (defmethod add-output-hooks progn ((method delegating-direct-method) (reason (eql :c)) sequencer) (with-slots (class body) method @@ -420,6 +419,90 @@ (defmethod add-output-hooks progn ((class :direct-method method :end) (terpri stream))))) +;;;-------------------------------------------------------------------------- +;;; Vtables. + +(defmethod add-output-hooks progn + ((vtable vtable) (reason (eql :c)) sequencer) + (with-slots (class chain-head chain-tail) vtable + (sequence-output (stream sequencer) + :constraint ((class :vtables :start) + (class :vtable chain-head :start) + (class :vtable chain-head :end) + (class :vtables :end)) + ((class :vtable chain-head :start) + (format stream "/* Vtable for ~A chain. */~@ + static const struct ~A ~A = {~%" + chain-head + (vtable-struct-tag chain-tail chain-head) + (vtable-name chain-tail chain-head))) + ((class :vtable chain-head :end) + (format stream "};~2%"))))) + +(defmethod add-output-hooks progn + ((cptr class-pointer) (reason (eql :c)) sequencer) + (with-slots (class chain-head metaclass meta-chain-head) cptr + (sequence-output (stream sequencer) + :constraint ((class :vtable chain-head :start) + (class :vtable chain-head :class-pointer metaclass) + (class :vtable chain-head :end)) + ((class :vtable chain-head :class-pointer metaclass) + (format stream " &~A__classobj.~A.~A,~%" + (sod-class-metaclass class) + (sod-class-nickname meta-chain-head) + (sod-class-nickname metaclass)))))) + +(defmethod add-output-hooks progn + ((boff base-offset) (reason (eql :c)) sequencer) + (with-slots (class chain-head) boff + (sequence-output (stream sequencer) + :constraint ((class :vtable chain-head :start) + (class :vtable chain-head :base-offset) + (class :vtable chain-head :end)) + ((class :vtable chain-head :base-offset) + (format stream " offsetof(struct ~A, ~A),~%" + (ilayout-struct-tag class) + (sod-class-nickname chain-head)))))) + +(defmethod add-output-hooks progn + ((choff chain-offset) (reason (eql :c)) sequencer) + (with-slots (class chain-head target-head) choff + (sequence-output (stream sequencer) + :constraint ((class :vtable chain-head :start) + (class :vtable chain-head :chain-offset target-head) + (class :vtable chain-head :end)) + ((class :vtable chain-head :chain-offset target-head) + (format stream " SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%" + (ilayout-struct-tag class) + (sod-class-nickname chain-head) + (sod-class-nickname target-head)))))) + +(defmethod add-output-hooks progn + ((vtmsgs vtmsgs) (reason (eql :c)) sequencer) + (with-slots (class subclass chain-head) vtmsgs + (sequence-output (stream sequencer) + :constraint ((subclass :vtable chain-head :start) + (subclass :vtable chain-head :vtmsgs class :start) + (subclass :vtable chain-head :vtmsgs class :slots) + (subclass :vtable chain-head :vtmsgs class :end) + (subclass :vtable chain-head :end)) + ((subclass :vtable chain-head :vtmsgs class :start) + (format stream " { /* Method entries for ~A messages. */~%" + class)) + ((subclass :vtable chain-head :vtmsgs class :end) + (format stream " },~%"))))) + +(defmethod add-output-hooks progn + ((entry method-entry) (reason (eql :c)) sequencer) + (with-slots (method chain-head chain-tail) entry + (let* ((message (effective-method-message method)) + (class (effective-method-class method)) + (super (sod-message-class message))) + (sequence-output (stream sequencer) + ((class :vtable chain-head :vtmsgs super :slots) + (format stream " ~A,~%" + (method-entry-function-name method chain-head))))))) + ;;;-------------------------------------------------------------------------- ;;; Filling in the class object.