From 4818ff760f1568e90ad9523f4d16c349c954f4cb Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 22 Aug 2019 23:44:07 +0100
Subject: [PATCH] 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.
---
 doc/SYMBOLS           |  16 ++++
 doc/output.tex        |  16 ++++
 src/class-output.lisp | 213 +++++++++++++++++++++++++++++++++-----------------
 3 files changed, 173 insertions(+), 72 deletions(-)

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 0396997..33f497f 100644
--- 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
--- 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
--- 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)
-- 
2.11.0

