New feature: messages with keyword arguments!

[sod] / src / method-proto.lisp

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index e0d87429d15df04697827b09a11c35816dd865e1..629e8a75efd87cda46c3d630397eca7c297e15f9 100644 (file)
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -28,11 +28,14 @@ (cl:in-package #:sod)
 ;;;--------------------------------------------------------------------------
 ;;; Effective methods and entries.
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective methods and entries.
 

-(export '(effective-method effective-method-message effective-method-class))
+(export '(effective-method
+         effective-method-message effective-method-class
+         effective-method-keywords))

 (defclass effective-method ()
   ((message :initarg :message :type sod-message
            :reader effective-method-message)
 (defclass effective-method ()
   ((message :initarg :message :type sod-message
            :reader effective-method-message)

-   (%class :initarg :class :type sod-class :reader effective-method-class))
+   (%class :initarg :class :type sod-class :reader effective-method-class)
+   (keywords :type list :reader effective-method-keywords))

   (:documentation
    "The behaviour invoked by sending a message to an instance of a class.
 
   (:documentation
    "The behaviour invoked by sending a message to an instance of a class.
 


@@ -42,10 +45,9 @@ (defclass effective-method ()
    This is not a useful class by itself.  Message classes are expected to
    define their own effective-method classes.
 
    This is not a useful class by itself.  Message classes are expected to
    define their own effective-method classes.
 

-   An effective method class must accept a `:direct-methods' initarg, which
+   An effective method class may accept a `:direct-methods' initarg, which

    will be a list of applicable methods sorted in most-to-least specific
    will be a list of applicable methods sorted in most-to-least specific

-   order.  (Either that or you have to add an overriding method to
-   `compute-sod-effective-method'."))
+   order."))

 
 (export 'sod-message-effective-method-class)
 (defgeneric sod-message-effective-method-class (message)
 
 (export 'sod-message-effective-method-class)
 (defgeneric sod-message-effective-method-class (message)


@@ -174,6 +176,14 @@ (defgeneric sod-method-function-name (method)
   (:documentation
    "Return the C function name for the direct method."))
 
   (:documentation
    "Return the C function name for the direct method."))
 

+(export 'keyword-message-p)
+(defun keyword-message-p (message)
+  "Answer whether the MESSAGE accepts a keyword arguments.
+
+   Dealing with keyword messages is rather fiddly, so this is useful to
+   know."
+  (typep (sod-message-type message) 'c-keyword-function-type))
+

 (export 'varargs-message-p)
 (defun varargs-message-p (message)
   "Answer whether the MESSAGE accepts a variable-length argument list.
 (export 'varargs-message-p)
 (defun varargs-message-p (message)
   "Answer whether the MESSAGE accepts a variable-length argument list.


@@ -209,10 +219,11 @@ (defgeneric effective-method-basic-argument-names (method)
    "Return a list of argument names to be passed to direct methods.
 
    The argument names are constructed from the message's arguments returned
    "Return a list of argument names to be passed to direct methods.
 
    The argument names are constructed from the message's arguments returned

-   by `sod-message-no-varargs-tail'.  The basic arguments are the ones
-   immediately derived from the programmer's explicitly stated arguments; the
-   `me' argument is not included, and neither are more exotic arguments added
-   as part of the method delegation protocol."))
+   by `sod-message-argument-tail', with any ellipsis replaced by an explicit
+   `va_list' argument.  The basic arguments are the ones immediately derived
+   from the programmer's explicitly stated arguments; the `me' argument is
+   not included, and neither are more exotic arguments added as part of the
+   method delegation protocol."))

 
 ;;;--------------------------------------------------------------------------
 ;;; Code generation.
 
 ;;;--------------------------------------------------------------------------
 ;;; Code generation.


@@ -243,9 +254,11 @@ (defgeneric compute-effective-method-body (method codegen target)
    Writes the function body to the code generator.  It can (obviously)
    generate auxiliary functions if it needs to.
 
    Writes the function body to the code generator.  It can (obviously)
    generate auxiliary functions if it needs to.
 

-   The arguments are as specified by the `sod-message-no-varargs-tail', with
-   an additional argument `sod__obj' of type pointer-to-ilayout.  The code
-   should deliver the result (if any) to the TARGET."))
+   The arguments are as determined by agreement with the generic function
+   `compute-method-entry-functions'; usually this will be as specified by the
+   `sod-message-argument-tail', with any variable-argument tail reified to a
+   `va_list', and an additional argument `sod__obj' of type pointer-to-
+   ilayout.  The code should deliver the result (if any) to the TARGET."))

 
 (export 'simple-method-body)
 (defgeneric simple-method-body (method codegen target)
 
 (export 'simple-method-body)
 (defgeneric simple-method-body (method codegen target)


@@ -267,6 +280,42 @@ (definst convert-to-ilayout (stream :export t)
 
 ;;; Utilities.
 
 
 ;;; Utilities.
 

+(defvar *keyword-struct-disposition* :unset
+  "The current state of the keyword structure.
+
+   This can be one of four values.
+
+     * `:unset' -- the top-level default, mostly because I can't leave it
+       unbound and write this documentation.  Nothing that matters should see
+       this state.
+
+     * `:local' -- the structure itself is in a local variable `sod__kw'.
+       This is used in the top-level effective method.
+
+     * `:pointer' -- the structure is pointed to by the local variable
+       `sod__kw'.  This is used by delegation-chain trampolines.
+
+     * `:null' -- there is in fact no structure because none of the
+       applicable methods actually define any keywords.")
+
+(defun keyword-access (name &optional suffix)
+  "Return an lvalue designating a named member of the keyword struct.
+
+   If a non-nil SUFFIX is provided, then the member is named NAMESUFFIX."
+  (flet ((mem (op)
+          (format nil "~A~A~A~@[~A~]" *sod-keywords* op name suffix)))
+    (ecase *keyword-struct-disposition*
+      (:local (mem "."))
+      (:pointer (mem "->")))))
+
+(let ((kw-addr (format nil "&~A" *sod-keywords*)))
+  (defun keyword-struct-pointer ()
+    "Return a pointer to the keyword structure."
+    (ecase *keyword-struct-disposition*
+      (:local kw-addr)
+      (:pointer *sod-keywords*)
+      (:null *null-pointer*))))
+

 (export 'invoke-method)
 (defun invoke-method (codegen target arguments-tail direct-method)
   "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.
 (export 'invoke-method)
 (defun invoke-method (codegen target arguments-tail direct-method)
   "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.


@@ -283,22 +332,47 @@ (defun invoke-method (codegen target arguments-tail direct-method)
   (let* ((message (sod-method-message direct-method))
         (class (sod-method-class direct-method))
         (function (sod-method-function-name direct-method))
   (let* ((message (sod-method-message direct-method))
         (class (sod-method-class direct-method))
         (function (sod-method-function-name direct-method))

-        (arguments (cons (format nil "&sod__obj->~A.~A"
-                                 (sod-class-nickname
-                                  (sod-class-chain-head class))
-                                 (sod-class-nickname class))
-                         arguments-tail)))
-    (if (varargs-message-p message)
-       (convert-stmts codegen target
-                      (c-type-subtype (sod-method-type direct-method))
-                      (lambda (var)
-                        (ensure-var codegen *sod-tmp-ap* c-type-va-list)
-                        (deliver-call codegen :void "va_copy"
-                                      *sod-tmp-ap* *sod-ap*)
-                        (apply #'deliver-call codegen var
-                               function arguments)
-                        (deliver-call codegen :void "va_end" *sod-tmp-ap*)))
-       (apply #'deliver-call codegen target function arguments))))
+        (type (sod-method-type direct-method))
+        (keywordsp (keyword-message-p message))
+        (keywords (and keywordsp (c-function-keywords type)))
+        (arguments (append (list (format nil "&sod__obj->~A.~A"
+                                         (sod-class-nickname
+                                          (sod-class-chain-head class))
+                                         (sod-class-nickname class)))
+                           arguments-tail
+                           (mapcar (lambda (arg)
+                                     (let ((name (argument-name arg))
+                                           (default (argument-default arg)))
+                                       (if default
+                                           (make-cond-inst
+                                            (keyword-access name
+                                                            "__suppliedp")
+                                            (keyword-access name)
+                                            default)
+                                           (keyword-access name))))
+                                   keywords))))
+    (cond ((varargs-message-p message)
+          (convert-stmts codegen target (c-type-subtype type)
+                         (lambda (var)
+                           (ensure-var codegen *sod-tmp-ap* c-type-va-list)
+                           (deliver-call codegen :void "va_copy"
+                                         *sod-tmp-ap* *sod-ap*)
+                           (apply #'deliver-call codegen var
+                                  function arguments)
+                           (deliver-call codegen :void "va_end"
+                                         *sod-tmp-ap*))))
+         (keywords
+          (let ((tag (direct-method-suppliedp-struct-tag direct-method)))
+            (with-temporary-var (codegen spvar (c-type (struct tag)))
+              (dolist (arg keywords)
+                (let ((name (argument-name arg)))
+                  (deliver-expr codegen (format nil "~A.~A" spvar name)
+                                (keyword-access name "__suppliedp"))))
+              (setf arguments (list* (car arguments) spvar
+                                     (cdr arguments)))
+              (apply #'deliver-call codegen target function arguments))))
+         (t
+          (apply #'deliver-call codegen target function arguments)))))

 
 (export 'ensure-ilayout-var)
 (defun ensure-ilayout-var (codegen super)
 
 (export 'ensure-ilayout-var)
 (defun ensure-ilayout-var (codegen super)


@@ -337,12 +411,21 @@ (defun make-trampoline (codegen super body)
         (method (codegen-method codegen))
         (return-type (c-type-subtype message-type))
         (raw-args (sod-message-argument-tail message))
         (method (codegen-method codegen))
         (return-type (c-type-subtype message-type))
         (raw-args (sod-message-argument-tail message))

-        (arguments (if (varargs-message-p message)
-                       (cons (make-argument *sod-ap* c-type-va-list)
-                             (butlast raw-args))
-                       raw-args)))
+        (arguments (cond ((varargs-message-p message)
+                          (cons (make-argument *sod-ap* c-type-va-list)
+                                (butlast raw-args)))
+                         ((keyword-message-p message)
+                          (cons (make-argument *sod-key-pointer*
+                                               (c-type (* (void :const))))
+                                raw-args))))
+        (*keyword-struct-disposition* t))

     (codegen-push codegen)
     (ensure-ilayout-var codegen super)
     (codegen-push codegen)
     (ensure-ilayout-var codegen super)

+    (when (and (keyword-message-p message)
+              (not (eq *keyword-struct-disposition* :null)))
+      (let ((tag (effective-method-keyword-struct-tag method)))
+       (ensure-var codegen *sod-keywords* (c-type (* (struct tag :const)))
+                   *sod-key-pointer*)))

     (funcall body (codegen-target codegen))
     (codegen-pop-function codegen (temporary-function)
                          (c-type (fun (lisp return-type)
     (funcall body (codegen-target codegen))
     (codegen-pop-function codegen (temporary-function)
                          (c-type (fun (lisp return-type)


@@ -406,9 +489,11 @@ (defun invoke-delegation-chain (codegen target basic-tail chain kernel)
    nil."
 
   (let* ((message (codegen-message codegen))
    nil."
 
   (let* ((message (codegen-message codegen))

-        (argument-tail (if (varargs-message-p message)
-                           (cons *sod-tmp-ap* basic-tail)
-                           basic-tail)))
+        (argument-tail (cond ((varargs-message-p message)
+                              (cons *sod-tmp-ap* basic-tail))
+                             ((keyword-message-p message)
+                              (cons (keyword-struct-pointer) basic-tail))
+                             (t basic-tail))))

     (labels ((next-trampoline (method chain)
               (if (or kernel chain)
                   (make-trampoline codegen (sod-method-class method)
     (labels ((next-trampoline (method chain)
               (if (or kernel chain)
                   (make-trampoline codegen (sod-method-class method)