lib/sod.h, src/class-{output,utilities}.lisp: Macros for messages.

Emit a C macro for each message defined, which just saves the ugly
messing duplication of the receiver and the messing about with vtables.

This feature isn't stable yet, so don't rely on it not changing.  For
example, I've not yet decided on whether or not to uppercase the message
name.

diff --git a/lib/sod.h b/lib/sod.h
index 919b92743874fc016b925014e15aa069a19076d3..cb6b046d182b77a63aa5038008d75d2a1687da69 100644 (file)
--- a/lib/sod.h
+++ b/lib/sod.h
@@ -124,6 +124,18 @@ struct sod_chain {
   ((struct cls##__ilayout *)                                           \
    ((char *)(obj) - offsetof(struct cls##__ilayout, chead)))
 
+/* --- @SOD__CAR@ --- *
+ *
+ * Arguments:  @...@ = a nonempty list of arguments
+ *
+ * Returns:    The first argument only.
+ */
+
+#if __STDC_VERSION__ >= 199901
+#  define SOD__CAR(...) SOD__CARx(__VA_LIST__, _)
+#  define SOD__CARx(a, ...) a
+#endif
+
 /*----- Utility macros ----------------------------------------------------*/
 
 /* --- @SOD_CLASSOF@ --- *

diff --git a/src/class-output.lisp b/src/class-output.lisp
index 687b22c91af7e30b22ae60ea915e80e2f1dca164..3345ac36f27c26d1ce7e516ee8f27a099c3feaec 100644 (file)
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -44,6 +44,7 @@ (defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer)
      (class :ichains :start) (class :ichains :end)
      (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
      (class :conversions)
+     (class :message-macros)
      (class :object)
      (:classes :end))
 
@@ -104,6 +105,63 @@ (defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer)
                     (sod-class-nickname super-head))))
         (terpri stream)))))
 
+  ;; Provide convenience macros for sending the newly defined messages.  (The
+  ;; macros work on all subclasses too.)
+  ;;
+  ;; We need each message's method entry type for this, so we need to dig it
+  ;; out of the vtmsgs structure.  Indeed, the vtmsgs for this class contains
+  ;; entries for precisely the messages we want to make macros for.
+  (when (sod-class-messages class)
+    (sequence-output (stream sequencer)
+      ((class :message-macros)
+       (let* ((vtable (find (sod-class-chain-head class)
+                           (sod-class-vtables class)
+                           :key #'vtable-chain-head))
+             (vtmsgs (find-if (lambda (item)
+                                (and (typep item 'vtmsgs)
+                                     (eql (vtmsgs-class item) class)))
+                              (vtable-body vtable))))
+        (format stream "/* Message invocation macros. */~%")
+        ;;(break)
+        (dolist (entry (vtmsgs-entries vtmsgs))
+          (let* ((type (method-entry-function-type entry))
+                 (args (c-function-arguments type))
+                 (method (method-entry-effective-method entry))
+                 (message (effective-method-message method))
+                 (in-names nil) (out-names nil) (varargsp nil) (me "me"))
+            (do ((args args (cdr args)))
+                ((endp args))
+              (let* ((raw-name (argument-name (car args)))
+                     (name (if (find raw-name
+                                     (list "_vt"
+                                           (sod-class-nickname class)
+                                           (sod-message-name message))
+                                     :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 "#if __STDC_VERSION__ >= 199901~%"))
+            (format stream "#define ~A(~{~A~^, ~}) ~
+                                  ~A->_vt->~A.~A(~{~A~^, ~})~%"
+                    (message-macro-name class message)
+                    (nreverse in-names)
+                    me
+                    (sod-class-nickname class)
+                    (sod-message-name message)
+                    (nreverse out-names))
+            (when varargsp
+              (format stream "#endif~%"))))
+        (terpri stream)))))
+
   ;; Generate vtmsgs structure for all superclasses.
   (hook-output (car (sod-class-vtables class))
                    'vtmsgs

diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp
index 491671deee554357de75496e73f88a609d3f756b..aa4ef175a979b271d9774267b0babf2d60114a6b 100644 (file)
--- a/src/class-utilities.lisp
+++ b/src/class-utilities.lisp
@@ -196,4 +196,8 @@ (export 'vtable-name)
 (defun vtable-name (class chain-head)
   (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
 
+(export 'message-macro-name)
+(defun message-macro-name (class message)
+  (format nil "~A_~A" class (sod-message-name message)))
+
 ;;;----- That's all, folks --------------------------------------------------