+;;; Class declarations.
+
+(export 'emit-class-typedef)
+(defgeneric emit-class-typedef (class stream)
+ (:documentation
+ "Emit a `typedef' for the CLASS's C class type to the output STREAM.
+
+ By default, this will be an alias for the class's home `ichain'
+ structure."))
+(defmethod emit-class-typedef ((class sod-class) stream)
+ (format stream "typedef struct ~A ~A;~%"
+ (ichain-struct-tag class (sod-class-chain-head class)) class))
+
+(export 'emit-class-object-decl)
+(defgeneric emit-class-object-decl (class stream)
+ (:documentation
+ "Emit the declaration and macros for the CLASS's class object.
+
+ This includes the main declaration, and the convenience macros for
+ referring to the class object's individual chains. Write everything to
+ the output STREAM."))
+(defmethod emit-class-object-decl ((class sod-class) stream)
+ (let ((metaclass (sod-class-metaclass class))
+ (metaroot (find-root-metaclass class)))
+
+ ;; Output the actual class object declaration, and the special
+ ;; `...__class' macro for the root-metaclass chain.
+ (format stream "/* The class object. */~@
+ extern const struct ~A ~A__classobj;~@
+ #define ~:*~A__class (&~:*~A__classobj.~A.~A)~%"
+ (ilayout-struct-tag metaclass) class
+ (sod-class-nickname (sod-class-chain-head metaroot))
+ (sod-class-nickname metaroot))
+
+ ;; Write the uglier `...__cls_...' macros for the class object's other
+ ;; chains, if any.
+ (dolist (chain (sod-class-chains metaclass))
+ (let ((tail (car chain)))
+ (unless (eq tail metaroot)
+ (format stream "#define ~A__cls_~A (&~2:*~A__classobj.~A.~A)~%"
+ class (sod-class-nickname (sod-class-chain-head tail))
+ (sod-class-nickname tail)))))
+ (terpri stream)))
+
+(export 'emit-class-conversion-macro)
+(defgeneric emit-class-conversion-macro (class super stream)
+ (:documentation
+ "Emit a macro for converting an instance of CLASS to an instance of SUPER.
+
+ By default this is named `CLASS__CONV_SPR'. In-chain upcasts are just a
+ trivial pointer cast, which any decent compiler will elide; cross-chain
+ upcasts use the `SOD_XCHAIN' macro. Write the macro to the output
+ STREAM."))
+(defmethod emit-class-conversion-macro
+ ((class sod-class) (super sod-class) stream)
+ (let ((super-head (sod-class-chain-head super)))
+ (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~
+ ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%"
+ class (sod-class-nickname super) super
+ (eq super-head (sod-class-chain-head class))
+ (sod-class-nickname super-head))))
+
+(export 'emit-message-macro-defn)
+(defgeneric emit-message-macro-defn
+ (class entry varargsp me in-names out-names stream)
+ (:documentation
+ "Output a message macro for invoking a method ENTRY, with given arguments.
+
+ The default method on `emit-message-macro' calcualates the necessary
+ argument lists and calls this function to actually write the necessary
+ `#define' line to the stream. The intended division of responsibilities
+ is that `emit-message-macro' handles the peculiarities of marshalling the
+ arguments to the method entry function, while `emit-message-macro-defn'
+ concerns itself with navigating the vtable to find the right function in
+ the first place.")
+ (:method :around ((class sod-class) (entry method-entry)
+ varargsp me in-names out-names
+ stream)
+ (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
+ (call-next-method)
+ (when varargsp (format stream "#endif~%"))))
+(defmethod emit-message-macro-defn ((class sod-class) (entry method-entry)
+ varargsp me in-names out-names
+ stream)
+ (format stream "#define ~A(~{~A~^, ~}) (~A)->_vt->~A.~A(~{~A~^, ~})~%"
+ (message-macro-name class entry)
+ in-names
+ me
+ (sod-class-nickname class)
+ (method-entry-slot-name entry)
+ out-names))
+
+(export 'emit-message-macro)
+(defgeneric emit-message-macro (class entry stream)
+ (:documentation
+ "Write a macro for invoking the method ENTRY on an instance of CLASS.
+
+ The default behaviour is quite complicated, particular when varargs or
+ keyword messages are involved."))
+(defmethod emit-message-macro ((class sod-class) (entry method-entry) stream)
+ (when (some (lambda (message)
+ (or (keyword-message-p message)
+ (varargs-message-p message)))
+ (sod-class-messages class)))
+ (let* ((type (method-entry-function-type entry))
+ (args (c-function-arguments type))
+ (in-names nil) (out-names nil) (varargsp nil) (me "me"))
+ (do ((args args (cdr args)))
+ ((endp args))
+ (let* ((raw-name (princ-to-string (argument-name (car args))))
+ (name (if (find raw-name
+ (list "_vt"
+ (sod-class-nickname class)
+ (method-entry-slot-name entry))
+ :test #'string=)
+ (format nil "sod__a_~A" raw-name)
+ raw-name)))
+ (cond ((and (cdr args) (eq (cadr args) :ellipsis))
+ (setf varargsp t)
+ (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
+ (push (format nil "/*~A*/ ..." name) in-names)
+ (push "__VA_ARGS__" out-names)
+ (return))
+ (t
+ (push name in-names)
+ (push name out-names)))))
+ (when varargsp (format stream "#ifdef SOD__HAVE_VARARGS_MACROS~%"))
+ (emit-message-macro-defn class entry varargsp me
+ (nreverse in-names)
+ (nreverse out-names)
+ stream)
+ (when varargsp (format stream "#endif~%"))))