X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/b426ab51d0598242a4c2b57d563341db66d71f7b..e417fab55d827640e10b832b85978847a1bfe5d5:/src/class-output.lisp diff --git a/src/class-output.lisp b/src/class-output.lisp index 2ab6363..35269a7 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -98,8 +98,8 @@ (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~)(p) ((~A *)~ - ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%" + (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)))) @@ -138,7 +138,7 @@ raw-name))) (cond ((and (cdr args) (eq (cadr args) :ellipsis)) (setf varargsp t) - (unless in-names (setf me "SOD__CAR(__VA_ARGS__)")) + (unless in-names (setf me "SOD_CAR(__VA_ARGS__)")) (push (format nil "/*~A*/ ..." name) in-names) (push "__VA_ARGS__" out-names) (return)) @@ -165,7 +165,7 @@ sequencer)) (defmethod hook-output progn ((class sod-class) reason sequencer) - (with-slots (ilayout vtables methods effective-methods) class + (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)) @@ -192,7 +192,7 @@ (hook-output item reason sequencer))) (defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer) - (with-slots (class ichains) ilayout + (with-slots ((class %class) ichains) ilayout (sequence-output (stream sequencer) ((class :ilayout :start) (format stream "/* Instance layout. */~@ @@ -204,7 +204,7 @@ (hook-output ichain 'ilayout sequencer)))) (defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) ichain + (with-slots ((class %class) chain-head chain-tail) ichain (when (eq class chain-tail) (sequence-output (stream sequencer) :constraint ((class :ichains :start) @@ -235,7 +235,7 @@ (defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout)) sequencer) - (with-slots (class chain-head chain-tail) ichain + (with-slots ((class %class) chain-head chain-tail) ichain (sequence-output (stream sequencer) ((class :ilayout :slots) (format stream " union ~A ~A;~%" @@ -245,7 +245,7 @@ (defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) vtptr + (with-slots ((class %class) chain-head chain-tail) vtptr (sequence-output (stream sequencer) ((class :ichain chain-head :slots) (format stream " const struct ~A *_vt;~%" @@ -256,7 +256,7 @@ (hook-output slot reason sequencer))) (defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer) - (with-slots (class subclass slots) islots + (with-slots ((class %class) subclass slots) islots (sequence-output (stream sequencer) ((subclass :ichain (sod-class-chain-head class) :slots) (format stream " struct ~A ~A;~%" @@ -273,7 +273,7 @@ (defmethod hook-output progn ((method sod-method) (reason (eql :h)) sequencer) - (with-slots (class) method + (with-slots ((class %class)) method (sequence-output (stream sequencer) ((class :methods) (let ((type (sod-method-function-type method))) @@ -283,7 +283,7 @@ (format stream ";~%")))))) (defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) vtable + (with-slots ((class %class) chain-head chain-tail) vtable (when (eq class chain-tail) (sequence-output (stream sequencer) :constraint ((class :vtables :start) @@ -296,15 +296,27 @@ struct ~A {~%" (vtable-struct-tag chain-tail chain-head))) ((class :vtable chain-head :end) - (format stream "};~2%")))) + (format stream "};~2%") + (format stream "/* Union of equivalent superclass vtables. */~@ + union ~A {~@ + ~:{ struct ~A ~A;~%~}~ + };~2%" + (vtable-union-tag chain-tail chain-head) + + ;; As for the ichain union, make sure the most specific + ;; class is first. + (mapcar (lambda (super) + (list (vtable-struct-tag super chain-head) + (sod-class-nickname super))) + (sod-class-chain chain-tail)))))) (sequence-output (stream sequencer) ((class :vtable-externs) - (format stream "~@~%" - (vtable-struct-tag chain-tail chain-head) + (format stream "~@~%" + (vtable-union-tag chain-tail chain-head) class (sod-class-nickname chain-head)))))) (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer) - (with-slots (class subclass chain-head chain-tail) vtmsgs + (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs (sequence-output (stream sequencer) ((subclass :vtable chain-head :slots) (format stream " struct ~A ~A;~%" @@ -315,7 +327,7 @@ (reason (eql 'vtmsgs)) sequencer) (when (vtmsgs-entries vtmsgs) - (with-slots (class subclass) vtmsgs + (with-slots ((class %class) subclass) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtmsgs :start) (subclass :vtmsgs class :start) @@ -352,7 +364,7 @@ (defmethod hook-output progn ((cptr class-pointer) (reason (eql :h)) sequencer) - (with-slots (class chain-head metaclass meta-chain-head) cptr + (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~];~%" @@ -361,7 +373,7 @@ (sod-class-nickname meta-chain-head))))))) (defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer) - (with-slots (class chain-head) boff + (with-slots ((class %class) chain-head) boff (sequence-output (stream sequencer) ((class :vtable chain-head :slots) (write-line " size_t _base;" stream))))) @@ -369,7 +381,7 @@ (defmethod hook-output progn ((choff chain-offset) (reason (eql :h)) sequencer) - (with-slots (class chain-head target-head) choff + (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) ((class :vtable chain-head :slots) (format stream " ptrdiff_t _off_~A;~%" @@ -415,7 +427,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c)) sequencer) - (with-slots (class body) method + (with-slots ((class %class) body) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) @@ -430,7 +442,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method sod-method) (reason (eql :c)) sequencer) - (with-slots (class body) method + (with-slots ((class %class) body) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) @@ -452,7 +464,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method basic-effective-method) (reason (eql :c)) sequencer) - (with-slots (class functions) method + (with-slots ((class %class) functions) method (sequence-output (stream sequencer) ((class :effective-methods) (dolist (func functions) @@ -462,7 +474,7 @@ const struct ~A ~A__classobj = {~%" ;;; Vtables. (defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer) - (with-slots (class chain-head chain-tail) vtable + (with-slots ((class %class) chain-head chain-tail) vtable (sequence-output (stream sequencer) :constraint ((class :vtables :start) (class :vtable chain-head :start) @@ -470,17 +482,17 @@ const struct ~A ~A__classobj = {~%" (class :vtables :end)) ((class :vtable chain-head :start) (format stream "/* Vtable for ~A chain. */~@ - const struct ~A ~A = {~%" + const union ~A ~A = { {~%" chain-head - (vtable-struct-tag chain-tail chain-head) + (vtable-union-tag chain-tail chain-head) (vtable-name class chain-head))) ((class :vtable chain-head :end) - (format stream "};~2%"))))) + (format stream "} };~2%"))))) (defmethod hook-output progn ((cptr class-pointer) (reason (eql :c)) sequencer) - (with-slots (class chain-head metaclass meta-chain-head) cptr + (with-slots ((class %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) @@ -496,7 +508,7 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname metaclass)))))) (defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer) - (with-slots (class chain-head) boff + (with-slots ((class %class) chain-head) boff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :base-offset) @@ -510,7 +522,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((choff chain-offset) (reason (eql :c)) sequencer) - (with-slots (class chain-head target-head) choff + (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :chain-offset target-head) @@ -523,7 +535,7 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname target-head)))))) (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer) - (with-slots (class subclass chain-head) vtmsgs + (with-slots ((class %class) subclass chain-head) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtable chain-head :start) (subclass :vtable chain-head :vtmsgs class :start) @@ -539,7 +551,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((entry method-entry) (reason (eql :c)) sequencer) - (with-slots (method chain-head chain-tail role) entry + (with-slots ((method %method) chain-head chain-tail role) entry (let* ((message (effective-method-message method)) (class (effective-method-class method)) (super (sod-message-class message))) @@ -555,7 +567,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((ichain ichain) (reason (eql 'class)) sequencer) - (with-slots (class chain-head) ichain + (with-slots ((class %class) chain-head) ichain (sequence-output (stream sequencer) :constraint ((*instance-class* :object :start) (*instance-class* :object chain-head :ichain :start) @@ -570,7 +582,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((islots islots) (reason (eql 'class)) sequencer) - (with-slots (class) islots + (with-slots ((class %class)) islots (let ((chain-head (sod-class-chain-head class))) (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) @@ -586,14 +598,16 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class)) sequencer) - (with-slots (class chain-head chain-tail) vtptr + (with-slots ((class %class) chain-head chain-tail) vtptr (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) (*instance-class* :object chain-head :vtable) (*instance-class* :object chain-head :ichain :end)) ((*instance-class* :object chain-head :vtable) - (format stream " &~A__vtable_~A,~%" - class (sod-class-nickname chain-head)))))) + (format stream " /* ~17@A = */ &~A.~A,~%" + "_vt" + (vtable-name class chain-head) + (sod-class-nickname chain-tail)))))) (defgeneric find-class-initializer (slot class) (:method ((slot effective-slot) (class sod-class)) @@ -637,7 +651,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((slot effective-slot) (reason (eql 'class)) sequencer) - (with-slots (class (dslot slot)) slot + (with-slots ((class %class) (dslot slot)) slot (let ((instance *instance-class*) (super (sod-slot-class dslot))) (sequence-output (stream sequencer)