X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/08713508fa747fae29e357e8079038bd6fcc4e0b..61d083c621c983b7bb06a2d7f3d2dc2a80a442b7:/src/class-output.lisp

diff --git a/src/class-output.lisp b/src/class-output.lisp
index c74daa8..2ab6363 100644
--- 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,60 @@
 		     (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. */~%")
+	 (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 "#if __STDC_VERSION__ >= 199901~%"))
+	     (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~%"))))
+	 (terpri stream)))))
+
   ;; Generate vtmsgs structure for all superclasses.
   (hook-output (car (sod-class-vtables class))
 		    'vtmsgs
@@ -291,7 +346,7 @@
     (sequence-output (stream sequencer)
       ((class :vtmsgs (sod-message-class message) :slots)
        (pprint-logical-block (stream nil :prefix "  " :suffix ";")
-	 (pprint-c-type pointer-type stream (sod-message-name message)))
+	 (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
        (terpri stream)))))
 
 (defmethod hook-output progn ((cptr class-pointer)
@@ -436,7 +491,7 @@ const struct ~A ~A__classobj = {~%"
 		   (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))))))
 
@@ -484,15 +539,15 @@ const struct ~A ~A__classobj = {~%"
 (defmethod hook-output progn ((entry method-entry)
 			      (reason (eql :c))
 			      sequencer)
-  (with-slots (method chain-head chain-tail) entry
+  (with-slots (method chain-head chain-tail role) entry
     (let* ((message (effective-method-message method))
 	   (class (effective-method-class method))
 	   (super (sod-message-class message)))
       (sequence-output (stream sequencer)
 	((class :vtable chain-head :vtmsgs super :slots)
 	 (format stream "    /* ~19@A = */ ~A,~%"
-		 (sod-message-name message)
-		 (method-entry-function-name method chain-head)))))))
+		 (method-entry-slot-name entry)
+		 (method-entry-function-name method chain-head role)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Filling in the class object.