((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))
(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)
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))))
;;;--------------------------------------------------------------------------
(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)
(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)
(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)
(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)))
((: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))
;;;--------------------------------------------------------------------------
;;; 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
((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.
~mdw / sod / blobdiff