X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/bb172d5341a0c453bdf46ac4ef5dd68c8077c724..df9b9a638bab60dfe28be0ad8606ed20c6c0cfba:/src/class-output.lisp diff --git a/src/class-output.lisp b/src/class-output.lisp index d914864..a975ebe 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -26,6 +26,34 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- +;;; Walking the layout tree. + +(defmethod hook-output progn ((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) + (with-slots (ichains) ilayout + (dolist (ichain ichains) (hook-output ichain reason sequencer)))) + +(defmethod hook-output progn ((ichain ichain) reason sequencer) + (dolist (item (ichain-body ichain)) (hook-output item reason sequencer))) + +(defmethod hook-output progn ((islots islots) reason sequencer) + (dolist (slot (islots-slots islots)) (hook-output slot reason sequencer))) + +(defmethod hook-output progn ((vtable vtable) reason sequencer) + (with-slots (body) vtable + (dolist (item body) (hook-output item reason sequencer)))) + +(defmethod hook-output progn ((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) @@ -160,39 +188,21 @@ (terpri stream))))) ;; Generate vtmsgs structure for all superclasses. - (hook-output (car (sod-class-vtables class)) - 'vtmsgs - sequencer)) - -(defmethod hook-output progn ((class sod-class) reason sequencer) - (with-slots (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)))) + (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 progn + ((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 sequencer) - (with-slots (ichains) ilayout - (dolist (ichain ichains) (hook-output ichain reason sequencer)))) - -(defmethod hook-output progn ((ichain ichain) reason sequencer) - (dolist (item (ichain-body ichain)) - (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 +214,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) @@ -232,10 +242,9 @@ (sod-class-nickname super))) (sod-class-chain chain-tail)))))))) -(defmethod hook-output progn ((ichain ichain) - (reason (eql 'ilayout)) - sequencer) - (with-slots (class chain-head chain-tail) ichain +(defmethod hook-output progn + ((ichain ichain) (reason (eql 'ilayout)) sequencer) + (with-slots ((class %class) chain-head chain-tail) ichain (sequence-output (stream sequencer) ((class :ilayout :slots) (format stream " union ~A ~A;~%" @@ -245,18 +254,14 @@ (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;~%" (vtable-struct-tag chain-tail chain-head)))))) -(defmethod hook-output progn ((islots islots) reason sequencer) - (dolist (slot (islots-slots islots)) - (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;~%" @@ -266,14 +271,9 @@ ;;;-------------------------------------------------------------------------- ;;; Vtable structure. -(defmethod hook-output progn ((vtable vtable) reason sequencer) - (with-slots (body) vtable - (dolist (item body) (hook-output item reason sequencer)))) - -(defmethod hook-output progn ((method sod-method) - (reason (eql :h)) - sequencer) - (with-slots (class) method +(defmethod hook-output progn + ((method sod-method) (reason (eql :h)) sequencer) + (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) @@ -311,23 +311,22 @@ (sod-class-chain chain-tail)))))) (sequence-output (stream sequencer) ((class :vtable-externs) - (format stream "~@~%" + (format stream "~@~%" (vtable-union-tag chain-tail chain-head) - class (sod-class-nickname chain-head)))))) + (vtable-name class 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;~%" (vtmsgs-struct-tag subclass class) (sod-class-nickname class)))))) -(defmethod hook-output progn ((vtmsgs vtmsgs) - (reason (eql 'vtmsgs)) - sequencer) +(defmethod hook-output progn + ((vtmsgs vtmsgs) (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) @@ -342,13 +341,8 @@ ((subclass :vtmsgs class :end) (format stream "};~2%")))))) -(defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer) - (with-slots (entries) vtmsgs - (dolist (entry entries) (hook-output entry reason sequencer)))) - -(defmethod hook-output progn ((entry method-entry) - (reason (eql 'vtmsgs)) - sequencer) +(defmethod hook-output progn + ((entry method-entry) (reason (eql 'vtmsgs)) sequencer) (let* ((method (method-entry-effective-method entry)) (message (effective-method-message method)) (class (effective-method-class method)) @@ -361,10 +355,9 @@ (pprint-c-type pointer-type stream (method-entry-slot-name entry))) (terpri stream))))) -(defmethod hook-output progn ((cptr class-pointer) - (reason (eql :h)) - sequencer) - (with-slots (class chain-head metaclass meta-chain-head) cptr +(defmethod hook-output progn + ((cptr class-pointer) (reason (eql :h)) sequencer) + (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~];~%" @@ -373,15 +366,14 @@ (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))))) -(defmethod hook-output progn ((choff chain-offset) - (reason (eql :h)) - sequencer) - (with-slots (class chain-head target-head) choff +(defmethod hook-output progn + ((choff chain-offset) (reason (eql :h)) sequencer) + (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) ((class :vtable chain-head :slots) (format stream " ptrdiff_t _off_~A;~%" @@ -390,7 +382,16 @@ ;;;-------------------------------------------------------------------------- ;;; Implementation output. -(defvar *instance-class*) +(export '*instance-class*) +(defvar *instance-class* nil + "The class currently being output. + + This is bound during the `hook-output' traversal of a class layout for + `:c' output, since some of the objects traversed actually `belong' to + superclasses and there's no other way to find out what the reference class + actually is. + + It may be bound at other times.") (defmethod hook-output progn ((class sod-class) (reason (eql :c)) sequencer) (sequence-output (stream sequencer) @@ -418,16 +419,14 @@ const struct ~A ~A__classobj = {~%" (let ((*instance-class* class)) (hook-output (sod-class-ilayout (sod-class-metaclass class)) - 'class - sequencer))) + 'class sequencer))) ;;;-------------------------------------------------------------------------- ;;; Direct and effective methods. -(defmethod hook-output progn ((method delegating-direct-method) - (reason (eql :c)) - sequencer) - (with-slots (class body) method +(defmethod hook-output progn + ((method delegating-direct-method) (reason (eql :c)) sequencer) + (with-slots ((class %class) body) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) @@ -439,10 +438,9 @@ const struct ~A ~A__classobj = {~%" ((class :direct-method method :end) (format stream "#undef CALL_NEXT_METHOD~%"))))) -(defmethod hook-output progn ((method sod-method) - (reason (eql :c)) - sequencer) - (with-slots (class body) method +(defmethod hook-output progn + ((method sod-method) (reason (eql :c)) sequencer) + (with-slots ((class %class) body) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) @@ -461,10 +459,9 @@ const struct ~A ~A__classobj = {~%" ((class :direct-method method :end) (terpri stream))))) -(defmethod hook-output progn ((method basic-effective-method) - (reason (eql :c)) - sequencer) - (with-slots (class functions) method +(defmethod hook-output progn + ((method basic-effective-method) (reason (eql :c)) sequencer) + (with-slots ((class %class) functions) method (sequence-output (stream sequencer) ((class :effective-methods) (dolist (func functions) @@ -474,7 +471,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) @@ -489,10 +486,9 @@ const struct ~A ~A__classobj = {~%" ((class :vtable chain-head :end) (format stream "} };~2%"))))) -(defmethod hook-output progn ((cptr class-pointer) - (reason (eql :c)) - sequencer) - (with-slots (class chain-head metaclass meta-chain-head) cptr +(defmethod hook-output progn + ((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) (class :vtable chain-head :class-pointer metaclass) @@ -508,7 +504,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) @@ -519,10 +515,9 @@ 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) - (with-slots (class chain-head target-head) choff +(defmethod hook-output progn + ((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) (class :vtable chain-head :chain-offset target-head) @@ -535,7 +530,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) @@ -548,10 +543,9 @@ 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) - (with-slots (method chain-head chain-tail role) entry +(defmethod hook-output progn + ((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)) (super (sod-message-class message))) @@ -564,10 +558,9 @@ const struct ~A ~A__classobj = {~%" ;;;-------------------------------------------------------------------------- ;;; Filling in the class object. -(defmethod hook-output progn ((ichain ichain) - (reason (eql 'class)) - sequencer) - (with-slots (class chain-head) ichain +(defmethod hook-output progn + ((ichain ichain) (reason (eql 'class)) sequencer) + (with-slots ((class %class) chain-head) ichain (sequence-output (stream sequencer) :constraint ((*instance-class* :object :start) (*instance-class* :object chain-head :ichain :start) @@ -579,10 +572,9 @@ const struct ~A ~A__classobj = {~%" ((*instance-class* :object chain-head :ichain :end) (format stream " } },~%"))))) -(defmethod hook-output progn ((islots islots) - (reason (eql 'class)) - sequencer) - (with-slots (class) islots +(defmethod hook-output progn + ((islots islots) (reason (eql 'class)) sequencer) + (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) @@ -595,10 +587,9 @@ const struct ~A ~A__classobj = {~%" ((*instance-class* :object class :slots :end) (format stream " },~%")))))) -(defmethod hook-output progn ((vtptr vtable-pointer) - (reason (eql 'class)) - sequencer) - (with-slots (class chain-head chain-tail) vtptr +(defmethod hook-output progn + ((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) (*instance-class* :object chain-head :vtable) @@ -638,9 +629,8 @@ const struct ~A ~A__classobj = {~%" (sod-slot-name direct-slot) (sod-initializer-value-form init))))))) -(defmethod hook-output progn ((slot sod-class-effective-slot) - (reason (eql 'class)) - sequencer) +(defmethod hook-output progn + ((slot sod-class-effective-slot) (reason (eql 'class)) sequencer) (let ((instance *instance-class*) (func (effective-slot-prepare-function slot))) (when func @@ -648,10 +638,9 @@ const struct ~A ~A__classobj = {~%" ((instance :object :prepare) (funcall func instance stream)))))) -(defmethod hook-output progn ((slot effective-slot) - (reason (eql 'class)) - sequencer) - (with-slots (class (dslot slot)) slot +(defmethod hook-output progn + ((slot effective-slot) (reason (eql 'class)) sequencer) + (with-slots ((class %class) (dslot slot)) slot (let ((instance *instance-class*) (super (sod-slot-class dslot))) (sequence-output (stream sequencer)