(class :vtmsgs :start) (class :vtmsgs :end)
(class :vtables :start) (class :vtables :end)
(class :vtable-externs) (class :vtable-externs-after)
- (class :direct-methods)
+ (class :methods :start) (class :methods) (class :methods :end)
(class :ichains :start) (class :ichains :end)
(class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
(class :conversions)
+ (class :object)
(:classes :end))
(:typedefs
((class :banner)
(banner (format nil "Class ~A" class) stream))
((class :vtable-externs-after)
- (terpri stream)))
+ (terpri stream))
+
+ ((class :vtable-externs)
+ (format stream "/* Vtable structures. */~%"))
+
+ ((class :object)
+ (let ((metaclass (sod-class-metaclass class))
+ (metaroot (find-root-metaclass class)))
+ (format stream "/* The class object. */~%~
+ extern 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))
+ (sod-class-nickname metaroot)))))
;; Maybe generate an islots structure.
(when (sod-class-slots class)
(add-output-hooks slot 'populate-islots sequencer))
(sequence-output (stream sequencer)
((class :islots :start)
- (format stream "struct ~A {~%" (islots-struct-tag class)))
+ (format stream "/* Instance slots. */~%~
+ struct ~A {~%"
+ (islots-struct-tag class)))
((class :islots :end)
(format stream "};~2%"))))
;; Declare the direct methods.
(when (sod-class-methods class)
- (dolist (method (sod-class-methods class))
- (add-output-hooks method :declare-direct-methods sequencer))
(sequence-output (stream sequencer)
- ((class :direct-methods)
+ ((class :methods :start)
+ (format stream "/* Direct methods. */~%"))
+ ((class :methods :end)
(terpri stream))))
;; Provide upcast macros which do the right thing.
(sequence-output (stream sequencer)
((class :conversions)
(let ((chain-head (sod-class-chain-head class)))
+ (format stream "/* Conversion macros. */~%")
(dolist (super (cdr (sod-class-precedence-list class)))
(let ((super-head (sod-class-chain-head super)))
- (format stream (concatenate 'string "#define "
- "~:@(~A__CONV_~A~)(p) ((~A *)"
- "~:[SOD_XCHAIN(~A, p)~;p~])~%")
+ (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~
+ ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%"
class (sod-class-nickname super) super
(eq chain-head super-head)
- (sod-class-nickname super-head))))))))
+ (sod-class-nickname super-head))))
+ (terpri stream)))))
;; Generate vtmsgs structure for all superclasses.
(add-output-hooks (car (sod-class-vtables class))
sequencer))
(defmethod add-output-hooks progn ((class sod-class) reason sequencer)
- (with-slots (ilayout vtables) class
+ (with-slots (ilayout vtables methods) class
(add-output-hooks ilayout reason sequencer)
+ (dolist (method 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 "struct ~A {~%" (ilayout-struct-tag class)))
+ (format stream "/* Instance layout. */~%~
+ struct ~A {~%"
+ (ilayout-struct-tag class)))
((class :ilayout :end)
(format stream "};~2%")))
(dolist (ichain ichains)
(defmethod add-output-hooks progn
((ichain ichain) (reason (eql :h)) sequencer)
- (with-slots (class chain-head) ichain
- (sequence-output (stream sequencer)
- :constraint ((class :ichains :start)
- (class :ichain chain-head :start)
- (class :ichain chain-head :slots)
- (class :ichain chain-head :end)
- (class :ichains :end))
- ((class :ichain chain-head :start)
- (format stream "struct ~A {~%" (ichain-struct-tag class chain-head)))
- ((class :ichain chain-head :end)
- (format stream "};~2%")))))
+ (with-slots (class chain-head chain-tail) ichain
+ (when (eq class chain-tail)
+ (sequence-output (stream sequencer)
+ :constraint ((class :ichains :start)
+ (class :ichain chain-head :start)
+ (class :ichain chain-head :slots)
+ (class :ichain chain-head :end)
+ (class :ichains :end))
+ ((class :ichain chain-head :start)
+ (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 {~%~
+ ~:{ struct ~A ~A;~%~}~
+ };~2%"
+ (ichain-union-tag chain-tail chain-head)
+ (mapcar (lambda (super)
+ (list (ichain-struct-tag super chain-head)
+ (sod-class-nickname super)))
+ (sod-class-chain chain-tail))))))))
(defmethod add-output-hooks progn
((ichain ichain) (reason (eql 'populate-ilayout)) sequencer)
- (with-slots (class chain-head) ichain
+ (with-slots (class chain-head chain-tail) ichain
(sequence-output (stream sequencer)
((class :ilayout :slots)
- (format stream " struct ~A ~A;~%"
- (ichain-struct-tag class chain-head)
+ (format stream " union ~A ~A;~%"
+ (ichain-union-tag chain-tail chain-head)
(sod-class-nickname chain-head))))))
-(defmethod add-output-hooks progn ((ichain ichain) reason sequencer)
- (with-slots (body) ichain
- (dolist (item body) (add-output-hooks item reason sequencer))))
-
(defmethod add-output-hooks progn
((vtptr vtable-pointer) (reason (eql :h)) sequencer)
- (with-slots (class chain-head) vtptr
+ (with-slots (class chain-head chain-tail) vtptr
(sequence-output (stream sequencer)
((class :ichain chain-head :slots)
(format stream " const struct ~A *_vt;~%"
- (vtable-struct-tag class chain-head))))))
+ (vtable-struct-tag chain-tail chain-head))))))
(defmethod add-output-hooks progn
((islots islots) (reason (eql :h)) sequencer)
(dolist (item body) (add-output-hooks item reason sequencer))))
(defmethod add-output-hooks progn
+ ((method sod-method) (reason (eql :h)) sequencer)
+ (with-slots (class) method
+ (sequence-output (stream sequencer)
+ ((class :methods)
+ (let ((type (sod-method-function-type method)))
+ (princ "extern " stream)
+ (pprint-c-type (commentify-function-type type) stream
+ (sod-method-function-name method))
+ (format stream ";~%"))))))
+
+(defmethod add-output-hooks progn
((vtable vtable) (reason (eql :h)) sequencer)
- (with-slots (class chain-head) vtable
+ (with-slots (class chain-head chain-tail) vtable
+ (when (eq class chain-tail)
+ (sequence-output (stream sequencer)
+ :constraint ((class :vtables :start)
+ (class :vtable chain-head :start)
+ (class :vtable chain-head :slots)
+ (class :vtable chain-head :end)
+ (class :vtables :end))
+ ((class :vtable chain-head :start)
+ (format stream "/* Vtable structure. */~%~
+ struct ~A {~%"
+ (vtable-struct-tag chain-tail chain-head)))
+ ((class :vtable chain-head :end)
+ (format stream "};~2%"))))
(sequence-output (stream sequencer)
- :constraint ((class :vtables :start)
- (class :vtable chain-head :start)
- (class :vtable chain-head :slots)
- (class :vtable chain-head :end)
- (class :vtables :end))
- ((class :vtable chain-head :start)
- (format stream "struct ~A {~%" (vtable-struct-tag class chain-head)))
- ((class :vtable chain-head :end)
- (format stream "};~2%"))
((class :vtable-externs)
(format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
- (vtable-struct-tag class chain-head)
+ (vtable-struct-tag chain-tail chain-head)
class (sod-class-nickname chain-head))))))
(defmethod add-output-hooks progn
((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
- (with-slots (class subclass chain-head) vtmsgs
+ (with-slots (class subclass chain-head chain-tail) vtmsgs
(sequence-output (stream sequencer)
((subclass :vtable chain-head :slots)
(format stream " struct ~A ~A;~%"
(subclass :vtmsgs class :end)
(subclass :vtmsgs :end))
((subclass :vtmsgs class :start)
- (format stream "struct ~A {~%" (vtmsgs-struct-tag subclass class)))
+ (format stream "/* Messages protocol from class ~A */~%~
+ struct ~A {~%"
+ class
+ (vtmsgs-struct-tag subclass class)))
((subclass :vtmsgs class :end)
(format stream "};~2%"))))))
(add-output-hooks method reason sequencer)))
(defmethod add-output-hooks progn
- ((method effective-method) (reason (eql 'populate-vtmsgs)) sequencer)
- (let* ((message (effective-method-message method))
+ ((entry method-entry) (reason (eql 'populate-vtmsgs)) sequencer)
+ (let* ((method (method-entry-effective-method entry))
+ (message (effective-method-message method))
(class (effective-method-class method))
- (class-type (find-class-type (sod-class-name class)))
- (raw-type (sod-message-type message))
- (type (c-type (* (fun (lisp (c-type-subtype raw-type))
- ("/*me*/" (* (lisp class-type)))
- . (commentify-argument-names
- (c-function-arguments raw-type)))))))
+ (type (method-entry-function-type entry))
+ (commented-type (commentify-function-type type)))
(sequence-output (stream sequencer)
((class :vtmsgs (sod-message-class message) :slots)
(pprint-logical-block (stream nil :prefix " " :suffix ";")
- (pprint-c-type type stream (sod-message-name message)))
+ (pprint-c-type commented-type stream (sod-message-name message)))
(terpri stream)))))
(defmethod add-output-hooks progn
~mdw / sod / blobdiff