src/class-output.lisp (find-class-initializer): Use correct keyword.

[sod] / src / class-output.lisp

diff --git a/src/class-output.lisp b/src/class-output.lisp
index 09f7e9f74aadcadb94a035197b95c4d9a79a3793..2d1c222635d945b94911f39b5a69e68c718a3d5f 100644 (file)
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -68,7 +68,8 @@ (defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer)
      (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 @@ (defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer)
   ;; 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 @@ (defmethod hook-output progn
         (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
@@ -486,6 +500,24 @@ (defmethod hook-output progn
   (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))))))
 
@@ -627,7 +659,7 @@ (defgeneric find-class-initializer (slot class)
     (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)))))
 
@@ -643,13 +675,9 @@ (defgeneric output-class-initializer (slot instance stream)
   (: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)