X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/1d8cc67a3f4ded443f5efc673a616883cbae9c50..9ec578d9fe450b7e7f9030dc9d930185593aa991:/src/class-output.lisp diff --git a/src/class-output.lisp b/src/class-output.lisp index b168d89..53812c9 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -110,11 +110,9 @@ sequencer)) (defmethod hook-output progn ((class sod-class) reason sequencer) - (with-slots (ilayout vtables methods effective-methods) class + (with-slots (ilayout vtables 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)))) ;;;-------------------------------------------------------------------------- @@ -245,7 +243,7 @@ (format stream "};~2%")))) (sequence-output (stream sequencer) ((class :vtable-externs) - (format stream "~@~%" + (format stream "~@~%" (vtable-struct-tag chain-tail chain-head) class (sod-class-nickname chain-head)))))) @@ -290,12 +288,13 @@ (let* ((method (method-entry-effective-method entry)) (message (effective-method-message method)) (class (effective-method-class method)) - (type (method-entry-function-type entry)) - (commented-type (commentify-function-type type))) + (function-type (method-entry-function-type entry)) + (commented-type (commentify-function-type function-type)) + (pointer-type (make-pointer-type commented-type))) (sequence-output (stream sequencer) ((class :vtmsgs (sod-message-class message) :slots) (pprint-logical-block (stream nil :prefix " " :suffix ";") - (pprint-c-type commented-type stream (sod-message-name message))) + (pprint-c-type pointer-type stream (sod-message-name message))) (terpri stream))))) (defmethod hook-output progn ((cptr class-pointer) @@ -306,9 +305,8 @@ ((class :vtable chain-head :slots) (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%" metaclass - (if (sod-class-direct-superclasses meta-chain-head) - (sod-class-nickname meta-chain-head) - nil)))))) + (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) (with-slots (class chain-head) boff @@ -360,7 +358,7 @@ const struct ~A ~A__classobj = {~%" sequencer))) ;;;-------------------------------------------------------------------------- -;;; Direct methods. +;;; Direct and effective methods. (defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c)) @@ -420,10 +418,10 @@ const struct ~A ~A__classobj = {~%" (class :vtables :end)) ((class :vtable chain-head :start) (format stream "/* Vtable for ~A chain. */~@ - static const struct ~A ~A = {~%" + const struct ~A ~A = {~%" chain-head (vtable-struct-tag chain-tail chain-head) - (vtable-name chain-tail chain-head))) + (vtable-name class chain-head))) ((class :vtable chain-head :end) (format stream "};~2%"))))) @@ -436,7 +434,11 @@ const struct ~A ~A__classobj = {~%" (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,~%" + (format stream " /* ~21@A = */ &~A__classobj.~A.~A,~%" + (if (sod-class-direct-superclasses meta-chain-head) + (format nil "_cls_~A" + (sod-class-nickname meta-chain-head)) + "_class") (sod-class-metaclass class) (sod-class-nickname meta-chain-head) (sod-class-nickname metaclass)))))) @@ -448,7 +450,8 @@ const struct ~A ~A__classobj = {~%" (class :vtable chain-head :base-offset) (class :vtable chain-head :end)) ((class :vtable chain-head :base-offset) - (format stream " offsetof(struct ~A, ~A),~%" + (format stream " /* ~21@A = */ offsetof(struct ~A, ~A),~%" + "_base" (ilayout-struct-tag class) (sod-class-nickname chain-head)))))) @@ -461,7 +464,8 @@ const struct ~A ~A__classobj = {~%" (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),~%" + (format stream " /* ~21@A = */ SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%" + (format nil "_off_~A" (sod-class-nickname target-head)) (ilayout-struct-tag class) (sod-class-nickname chain-head) (sod-class-nickname target-head)))))) @@ -489,7 +493,8 @@ const struct ~A ~A__classobj = {~%" (super (sod-message-class message))) (sequence-output (stream sequencer) ((class :vtable chain-head :vtmsgs super :slots) - (format stream " ~A,~%" + (format stream " /* ~19@A = */ ~A,~%" + (sod-message-name message) (method-entry-function-name method chain-head))))))) ;;;-------------------------------------------------------------------------- @@ -549,17 +554,23 @@ const struct ~A ~A__classobj = {~%" (defgeneric output-class-initializer (slot instance stream) (:method ((slot sod-class-effective-slot) (instance sod-class) stream) - (let ((func (effective-slot-initializer-function slot))) + (let ((func (effective-slot-initializer-function slot)) + (direct-slot (effective-slot-direct-slot slot))) (if func - (format stream " ~A,~%" (funcall func instance)) + (format stream " /* ~15@A = */ ~A,~%" + (sod-slot-name direct-slot) + (funcall func instance)) (call-next-method)))) (:method ((slot effective-slot) (instance sod-class) stream) - (let ((init (find-class-initializer slot instance))) + (let ((init (find-class-initializer slot instance)) + (direct-slot (effective-slot-direct-slot slot))) (ecase (sod-initializer-value-kind init) - (:simple (format stream " ~A,~%" + (:simple (format stream " /* ~15@A = */ ~A,~%" + (sod-slot-name direct-slot) (sod-initializer-value-form init))) - (:compound (format stream " ~@<{ ~;~A~; },~:>~%" - (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))