;;;--------------------------------------------------------------------------
;;; 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~%"))))
+
(defmethod hook-output ((class sod-class) (reason (eql :h)) sequencer)
;; Main output sequencing.
(class :object)
(:classes :end))
- (:typedefs
- (format stream "typedef struct ~A ~A;~%"
- (ichain-struct-tag class (sod-class-chain-head class)) class))
-
- ((class :banner)
- (banner (format nil "Class ~A" class) stream))
- ((class :vtable-externs-after)
- (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 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))
- (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))))
+ (:typedefs (emit-class-typedef class stream))
+ ((class :banner) (banner (format nil "Class ~A" class) stream))
+ ((class :vtable-externs-after) (terpri stream))
+ ((class :vtable-externs) (format stream "/* Vtable structures. */~%"))
+ ((class :object) (emit-class-object-decl class stream)))
;; Maybe generate an islots structure.
(when (sod-class-slots class)
(when (sod-class-direct-superclasses class)
(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 "#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))))
- (terpri stream)))))
+ (format stream "/* Conversion macros. */~%")
+ (dolist (super (cdr (sod-class-precedence-list class)))
+ (emit-class-conversion-macro class super stream))
+ (terpri stream))))
;; Provide convenience macros for sending the newly defined messages. (The
;; macros work on all subclasses too.)
(vtable-body vtable))))
(format stream "/* Message invocation macros. */~%")
(dolist (entry (vtmsgs-entries vtmsgs))
- (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~%"))
- (format stream "#define ~A(~{~A~^, ~}) ~
- (~A)->_vt->~A.~A(~{~A~^, ~})~%"
- (message-macro-name class entry)
- (nreverse in-names)
- me
- (sod-class-nickname class)
- (method-entry-slot-name entry)
- (nreverse out-names))
- (when varargsp
- (format stream "#endif~%"))))
+ (emit-message-macro class entry stream))
(terpri stream))))))
(defmethod hook-output :after ((class sod-class) (reason (eql :h)) sequencer)