X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/284f1fa2ace3e276052ff1bd7d66442500e693da..7524b4b2da30055e98de7f86507bec081b419f83:/src/class-output.lisp

diff --git a/src/class-output.lisp b/src/class-output.lisp
index b2d1ec8..2d1c222 100644
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -68,7 +68,8 @@
      (class :vtmsgs :start) (class :vtmsgs :end)
      (class :vtables :start) (class :vtables :end)
      (class :vtable-externs) (class :vtable-externs-after)
-     (class :methods :start) (class :methods) (class :methods :end)
+     (class :methods :start) (class :methods :defs)
+     (class :methods) (class :methods :end)
      (class :ichains :start) (class :ichains :end)
      (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
      (class :conversions)
@@ -139,7 +140,10 @@
   ;; 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 (some #'varargs-message-p (sod-class-messages class))
+  (when (some (lambda (message)
+		(or (keyword-message-p message)
+		    (varargs-message-p message)))
+	      (sod-class-messages class))
     (one-off-output 'varargs-macros sequencer :early-decls
 		    (lambda (stream)
 		      (format stream
@@ -288,7 +292,17 @@
 	 (princ "extern " stream)
 	 (pprint-c-type (commentify-function-type type) stream
 			(sod-method-function-name method))
-	 (format stream ";~%"))))))
+	 (format stream ";~%")))
+      ((class :methods :defs)
+       (let* ((type (sod-method-type method))
+	      (keys (and (typep type 'c-keyword-function-type)
+			 (c-function-keywords type))))
+	 (when keys
+	   (format stream "struct ~A {~%~
+			   ~{  unsigned ~A : 1;~%~}~
+			   };~2%"
+		   (direct-method-suppliedp-struct-tag method)
+		   (mapcar #'argument-name keys))))))))
 
 (defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer)
   (with-slots ((class %class) chain-head chain-tail) vtable
@@ -452,15 +466,25 @@ const struct ~A ~A__classobj = {~%"
 
 (defmethod hook-output progn
     ((method sod-method) (reason (eql :c)) sequencer)
-  (with-slots ((class %class) body) method
+  (with-slots ((class %class) role body message) method
     (unless body
       (return-from hook-output))
     (sequence-output (stream sequencer)
       :constraint ((class :direct-methods :start)
+		   (class :direct-method method :banner)
 		   (class :direct-method method :start)
 		   (class :direct-method method :body)
 		   (class :direct-method method :end)
 		   (class :direct-methods :end))
+      ((class :direct-method method :banner)
+       (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~
+				      on `~A.~A' ~:_defined by `~A'."
+			      role
+			      (sod-class-nickname
+			       (sod-message-class message))
+			      (sod-message-name message)
+			      class)
+       (fresh-line stream))
       ((class :direct-method method :body)
        (pprint-c-type (sod-method-function-type method)
 		      stream
@@ -476,6 +500,24 @@ const struct ~A ~A__classobj = {~%"
   (with-slots ((class %class) functions) method
     (sequence-output (stream sequencer)
       ((class :effective-methods)
+       (let* ((keys (effective-method-keywords method))
+	      (message (effective-method-message method))
+	      (msg-class (sod-message-class message)))
+	 (when keys
+	   (format-banner-comment stream "Keyword argument structure ~:_~
+					  for `~A.~A' ~:_on class `~A'."
+				  (sod-class-nickname msg-class)
+				  (sod-message-name message)
+				  class)
+	   (format stream "~&struct ~A {~%"
+		   (effective-method-keyword-struct-tag method))
+	   (format stream "~{  unsigned ~A__suppliedp : 1;~%~}"
+		   (mapcar #'argument-name keys))
+	   (dolist (key keys)
+	     (write-string "  " stream)
+	     (pprint-c-type (argument-type key) stream (argument-name key))
+	     (format stream ";~%"))
+	   (format stream "};~2%")))
        (dolist (func functions)
 	 (write func :stream stream :escape nil :circle nil))))))
 
@@ -617,7 +659,7 @@ const struct ~A ~A__classobj = {~%"
     (let ((dslot (effective-slot-direct-slot slot)))
       (or (some (lambda (super)
 		  (find dslot (sod-class-class-initializers super)
-			:test #'sod-initializer-slot))
+			:key #'sod-initializer-slot))
 		(sod-class-precedence-list class))
 	  (effective-slot-initializer slot)))))
 
@@ -633,13 +675,9 @@ const struct ~A ~A__classobj = {~%"
   (:method ((slot effective-slot) (instance sod-class) stream)
     (let ((init (find-class-initializer slot instance))
 	  (direct-slot (effective-slot-direct-slot slot)))
-      (ecase (sod-initializer-value-kind init)
-	(:simple (format stream "        /* ~15@A = */ ~A,~%"
-			 (sod-slot-name direct-slot)
-			 (sod-initializer-value-form init)))
-	(:compound (format stream "        /* ~15@A = */ ~@<{ ~;~A~; },~:>~%"
-			   (sod-slot-name direct-slot)
-			   (sod-initializer-value-form init)))))))
+      (format stream "        /* ~15@A = */ ~A,~%"
+	      (sod-slot-name direct-slot)
+	      (sod-initializer-value init)))))
 
 (defmethod hook-output progn
     ((slot sod-class-effective-slot) (reason (eql 'class)) sequencer)