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 919b927..cb6b046 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 687b22c..3345ac3 100644 (file)
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -44,6 +44,7 @@
      (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 @@
                     (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 491671d..aa4ef17 100644 (file)
--- a/src/class-utilities.lisp
+++ b/src/class-utilities.lisp
@@ -196,4 +196,8 @@
 (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 --------------------------------------------------