src/class-output.lisp: Split up `hook-output' on `sod-class' and `:h'.

Introduce five new generic functions to carry most of the load.  The
remaining `hook-output' functions all seem simple enough to be replaced
as necessary.

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 0396997..33f497f 100644 (file)
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -359,6 +359,11 @@ class-make-proto.lisp
 
 class-output.lisp
   *instance-class*                              variable
+  emit-class-conversion-macro                   generic
+  emit-class-object-decl                        generic
+  emit-class-typedef                            generic
+  emit-message-macro                            generic
+  emit-message-macro-defn                       generic
 
 class-utilities.lisp
   argument-lists-compatible-p                   function
@@ -1057,6 +1062,12 @@ effective-slot-initializer-function
   sod-class-effective-slot
 effective-slot-prepare-function
   sod-class-effective-slot
+emit-class-conversion-macro
+  sod-class sod-class t
+emit-class-object-decl
+  sod-class t
+emit-class-typedef
+  sod-class t
 emit-decl
   sod::basic-codegen t
 emit-decls
@@ -1066,6 +1077,11 @@ emit-inst
 emit-insts
   t t
   sod::basic-codegen t
+emit-message-macro
+  sod-class method-entry t
+emit-message-macro-defn
+  sod-class method-entry t t t t t
+  sod-class method-entry t t t t t [:around]
 ensure-sequencer-item
   sequencer t
 ensure-var

diff --git a/doc/output.tex b/doc/output.tex
index fc59bb4..27826ff 100644 (file)
--- a/doc/output.tex
+++ b/doc/output.tex
@@ -227,6 +227,22 @@ until the third.  So the final processing order is
 \begin{describe}{var}{*instance-class*}
 \end{describe}
 
+\begin{describe}{gf}{emit-class-typedef @<class> @<stream>}
+\end{describe}
+
+\begin{describe}{gf}{emit-class-object-decl @<class> @<stream>}
+\end{describe}
+
+\begin{describe}{gf}{emit-class-conversion-macro @<class> @<super> @<stream>}
+\end{describe}
+
+\begin{describe*}
+    {\dhead{gf}{emit-message-macro @<class> @<entry> @<stream>}
+     \dhead{gf}{emit-message-macro-defn
+                  \=@<class> @<entry> @<varargsp> @<me> \\
+                  \>@<in-names> @<out-names> @<stream>}}
+\end{describe*}
+
 %% output for `h' files
 %%
 %% prologue

diff --git a/src/class-output.lisp b/src/class-output.lisp
index 49453e9..f2d3e43 100644 (file)
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -56,6 +56,137 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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.
@@ -77,34 +208,11 @@
      (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)
@@ -128,16 +236,10 @@
   (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.)
@@ -165,40 +267,7 @@
                               (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)