src/c-types-parse.lisp: Parse `...' in argument lists.

[sod] / src / class-output.lisp

diff --git a/src/class-output.lisp b/src/class-output.lisp
index c74daa8ff6980bf9916c259b10f39f3d586b0c10..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
@@ -436,7 +494,7 @@ (defmethod hook-output progn ((cptr class-pointer)
                   (format nil "_cls_~A"
                           (sod-class-nickname meta-chain-head))
                   "_class")
-              (sod-class-metaclass class)
+              class
               (sod-class-nickname meta-chain-head)
               (sod-class-nickname metaclass))))))