Merge branches 'mdw/doc-reorg' and 'mdw/parser-fixes'

[sod] / src / method-proto.lisp

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index f5d8be7..f7f1f47 100644 (file)
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -63,6 +63,21 @@
 
    This protocol is used by `simple-message' subclasses."))
 
 
    This protocol is used by `simple-message' subclasses."))
 

+(export 'method-keyword-argument-lists)
+(defgeneric method-keyword-argument-lists (method 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 METHOD is the effective method being processed; 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-sod-effective-method)
 (defgeneric compute-sod-effective-method (message class)
   (:documentation
 (export 'compute-sod-effective-method)
 (defgeneric compute-sod-effective-method (message class)
   (:documentation


@@ -138,6 +153,16 @@
 
    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-method-description)
+(defgeneric sod-method-description (method)
+  (:documentation
+   "Return an adjectival phrase describing METHOD.
+
+    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)
   (:documentation
 (export 'sod-method-function-type)
 (defgeneric sod-method-function-type (method)
   (:documentation


@@ -216,6 +241,16 @@
    not included, and neither are more exotic arguments added as part of the
    method delegation protocol."))
 
    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.
 


@@ -271,14 +306,10 @@
 
 ;;; Utilities.
 
 
 ;;; Utilities.
 

-(defvar *keyword-struct-disposition* :unset
+(defvar-unbound *keyword-struct-disposition*

   "The current state of the keyword structure.
 
   "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.
+   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.
 
      * `:local' -- the structure itself is in a local variable `sod__kw'.
        This is used in the top-level effective method.


@@ -409,14 +440,17 @@
                           (cons (make-argument *sod-key-pointer*
                                                (c-type (* (void :const))))
                                 raw-args))))
                           (cons (make-argument *sod-key-pointer*
                                                (c-type (* (void :const))))
                                 raw-args))))

-        (*keyword-struct-disposition* t))
+        (*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)

-    (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*)))
+    (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)
     (funcall body (codegen-target codegen))
     (codegen-pop-function codegen (temporary-function)
                          (c-type (fun (lisp return-type)


@@ -480,11 +514,9 @@
    nil."
 
   (let* ((message (codegen-message codegen))
    nil."
 
   (let* ((message (codegen-message codegen))

-        (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))))
+        (argument-tail (if (varargs-message-p message)
+                           (cons *sod-tmp-ap* basic-tail)
+                           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)


@@ -495,9 +527,13 @@
               (if (null chain)
                   (funcall kernel target)
                   (let ((trampoline (next-trampoline (car chain)
               (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))))