src/method-{proto,impl}.lisp: Abstract out the receiver type.

[sod] / src / method-proto.lisp

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index c8b47ad..ed15ff2 100644 (file)
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -28,11 +28,14 @@
 ;;;--------------------------------------------------------------------------
 ;;; 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,71 @@
    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-receiver-type)
+(defgeneric sod-message-receiver-type (message class)
+  (:documentation
+   "Return the type of the `me' argument in a MESSAGE received by CLASS.
+
+   Typically this will just be `CLASS *'."))
+
+(export 'sod-message-applicable-methods)
+(defgeneric sod-message-applicable-methods (message class)
+  (:documentation
+   "Return a list of applicable methods for a MESSAGE.
+
+   The list contains all methods applicable for MESSAGE when sent to an
+   instance of CLASS, most specific first."))
+
+(export 'sod-message-keyword-argument-lists)
+(defgeneric sod-message-keyword-argument-lists
+    (message class direct-methods state)
+  (:documentation
+   "Returns a list of keyword argument lists to be merged.
+
+   This should return a list suitable for passing to `merge-keyword-lists',
+   i.e., each element should be a pair consisting of a function describing
+   the source of the argument list (returning location and description), and
+   a list of `argument' objects.
+
+   The MESSAGE is the message being processed; CLASS is a receiver class
+   under consideration; DIRECT-METHODS is the complete list of applicable
+   direct methods (most specific first); and STATE is an `inheritance-path-
+   reporter-state' object which can be used by the returned reporting
+   functions."))
+
+(export 'compute-effective-method-keyword-arguments)
+(defun compute-effective-method-keyword-arguments
+    (message class direct-methods)
+  "Return a merged keyword argument list.
+
+   The returned list combines all of the applicable methods, provided as
+   DIRECT-METHODS, applicable to MESSAGE when received by an instance of
+   CLASS, possibly with other keywords as determined by `sod-keyword-
+   argument-lists'."
+  (let ((state (make-inheritance-path-reporter-state class)))
+    (merge-keyword-lists (lambda ()
+                          (values class
+                                  (format nil
+                                          "methods for message `~A' ~
+                                           applicable to class `~A'"
+                                          message class)))
+                        (sod-message-keyword-argument-lists message
+                                                            class
+                                                            direct-methods
+                                                            state))))
+
+(export 'sod-message-check-methods)
+(defgeneric sod-message-check-methods (message class direct-methods)
+  (:documentation
+   "Check that the applicable methods for a MESSAGE are compatible.
+
+   Specifically, given the DIRECT-METHODS applicable for the message when
+   received by an instance of CLASS, signal errors if the methods don't
+   match the MESSAGE or each other."))

 
 (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)


@@ -78,7 +142,8 @@
    The list needn't be in any particular order."))
 
 (export '(method-entry method-entry-effective-method
    The list needn't be in any particular order."))
 
 (export '(method-entry method-entry-effective-method

-         method-entry-chain-head method-entry-chain-tail))
+         method-entry-chain-head method-entry-chain-tail
+         method-entry-role))

 (defclass method-entry ()
   ((%method :initarg :method :type effective-method
            :reader method-entry-effective-method)
 (defclass method-entry ()
   ((%method :initarg :method :type effective-method
            :reader method-entry-effective-method)


@@ -86,7 +151,7 @@
               :reader method-entry-chain-head)
    (chain-tail :initarg :chain-tail :type sod-class
               :reader method-entry-chain-tail)
               :reader method-entry-chain-head)
    (chain-tail :initarg :chain-tail :type sod-class
               :reader method-entry-chain-tail)

-   (role :initarg :role :type (or :keyword null) :reader method-entry-role))
+   (role :initarg :role :type (or keyword null) :reader method-entry-role))

   (:documentation
    "An entry point into an effective method.
 
   (:documentation
    "An entry point into an effective method.
 


@@ -136,14 +201,15 @@
 
    No `me' argument is prepended; any `:ellipsis' is left as it is."))
 
 
    No `me' argument is prepended; any `:ellipsis' is left as it is."))
 

-(export 'sod-message-no-varargs-tail)
-(defgeneric sod-message-no-varargs-tail (message)
+(export 'sod-method-description)
+(defgeneric sod-method-description (method)

   (:documentation
   (:documentation

-   "Return the argument tail for the message with `:ellipsis' substituted.
+   "Return an adjectival phrase describing METHOD.

 
 

-   As with `sod-message-argument-tail', no `me' argument is prepended.
-   However, an `:ellipsis' is replaced by an argument of type `va_list',
-   named `sod__ap'."))
+    The result will be placed into an error message reading something like
+    ``Conflicting definition of DESCRIPTION direct method `bogus'''.  Two
+    direct methods which can coexist in the same class, defined on the same
+    message, should have differing descriptions."))

 
 (export 'sod-method-function-type)
 (defgeneric sod-method-function-type (method)
 
 (export 'sod-method-function-type)
 (defgeneric sod-method-function-type (method)


@@ -174,6 +240,14 @@
   (: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.


@@ -197,6 +271,7 @@
 
    The default method indirects through `method-entry-slot-name-by-role'."))
 
 
    The default method indirects through `method-entry-slot-name-by-role'."))
 

+(export 'method-entry-slot-name-by-role)

 (defgeneric method-entry-slot-name-by-role (entry role name)
   (:documentation "Easier implementation for `method-entry-slot-name'.")
   (:method ((entry method-entry) (role (eql nil)) name) name)
 (defgeneric method-entry-slot-name-by-role (entry role name)
   (:documentation "Easier implementation for `method-entry-slot-name'.")
   (:method ((entry method-entry) (role (eql nil)) name) name)


@@ -209,10 +284,21 @@
    "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."))
+
+(export 'effective-method-live-p)
+(defgeneric effective-method-live-p (method)
+  (:documentation
+   "Returns true if the effective METHOD is live.
+
+   An effective method is `live' if it should actually have proper method
+   entry functions associated with it and stored in the class vtable.  The
+   other possibility is that the method is `dead', in which case the function
+   pointers in the vtable are left null."))

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


@@ -243,9 +329,11 @@
    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)


@@ -257,16 +345,45 @@
 
 ;;; Additional instructions.
 
 
 ;;; Additional instructions.
 

-;; HACK: use gensyms for the `class' and `expr' slots to avoid leaking the
-;; slot names, because `expr' is exported by our package, and `class' is
-;; actually from the `common-lisp' package.

 (definst convert-to-ilayout (stream :export t)
 (definst convert-to-ilayout (stream :export t)

-    (#1=#:class chain-head #2=#:expr)
+    (%class chain-head %expr)

   (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
   (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"

-         #1# (sod-class-nickname chain-head) #2#))
+         class (sod-class-nickname chain-head) expr))

 
 ;;; Utilities.
 
 
 ;;; Utilities.
 

+(defvar-unbound *keyword-struct-disposition*
+  "The current state of the keyword structure.
+
+   This can be one of three values.
+
+     * `: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,24 +400,47 @@
   (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)
-                        (emit-inst codegen
-                                   (make-va-copy-inst *sod-tmp-ap*
-                                                      *sod-ap*))
-                        (apply #'deliver-call codegen var
-                               function arguments)
-                        (emit-inst codegen
-                                   (make-va-end-inst *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)


@@ -335,19 +475,40 @@
 
   (let* ((message (codegen-message codegen))
         (message-type (sod-message-type message))
 
   (let* ((message (codegen-message codegen))
         (message-type (sod-message-type message))

+        (message-class (sod-message-class message))
+        (method (codegen-method codegen))

         (return-type (c-type-subtype message-type))
         (raw-args (sod-message-argument-tail message))
         (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))
+                         (t raw-args)))
+        (*keyword-struct-disposition* (if (effective-method-keywords method)
+                                          :pointer :null)))

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

+    (deliver-call codegen :void "SOD__IGNORE" "sod__obj")
+    (when (keyword-message-p message)
+      (if (eq *keyword-struct-disposition* :null)
+         (deliver-call codegen :void "SOD__IGNORE" *sod-key-pointer*)
+         (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)
                                       ("me" (* (class super)))
     (funcall body (codegen-target codegen))
     (codegen-pop-function codegen (temporary-function)
                          (c-type (fun (lisp return-type)
                                       ("me" (* (class super)))

-                                      . arguments)))))
+                                      . arguments))
+                         "Delegation-chain trampoline ~:_~
+                          for `~A.~A' ~:_on `~A'."
+                         (sod-class-nickname message-class)
+                         (sod-message-name message)
+                         (effective-method-class method))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Method entry protocol.
 
 ;;;--------------------------------------------------------------------------
 ;;; Method entry protocol.


@@ -409,14 +570,18 @@
                   (make-trampoline codegen (sod-method-class method)
                                    (lambda (target)
                                      (invoke chain target)))
                   (make-trampoline codegen (sod-method-class method)
                                    (lambda (target)
                                      (invoke chain target)))

-                  0))
+                  *null-pointer*))

             (invoke (chain target)
               (if (null chain)
                   (funcall kernel target)
                   (let ((trampoline (next-trampoline (car chain)
             (invoke (chain target)
               (if (null chain)
                   (funcall kernel target)
                   (let ((trampoline (next-trampoline (car chain)

-                                                     (cdr chain))))
+                                                     (cdr chain)))
+                        (tail (if (keyword-message-p message)
+                                  (cons (keyword-struct-pointer)
+                                        argument-tail)
+                                  argument-tail)))

                     (invoke-method codegen target
                     (invoke-method codegen target

-                                   (cons trampoline argument-tail)
+                                   (cons trampoline tail)

                                    (car chain))))))
       (invoke chain target))))
 
                                    (car chain))))))
       (invoke chain target))))