doc/syntax.tex: Delete (wrong) duplicate rule for <argument-declarator>.

[sod] / src / method-proto.lisp

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index f5d8be7a228f737136ee21c809eba410d08eb0d3..6f8dc02c75396601e4cb36d07b4350bd2519fec2 100644 (file)
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -63,6 +63,15 @@ (defgeneric primary-method-class (message)
 
    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)
+  (: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 list of `argument'
+   objects and a string describing the source of the argument list."))
+

 (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


@@ -216,6 +225,16 @@ (defgeneric effective-method-basic-argument-names (method)
    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.
 


@@ -409,14 +428,17 @@ (defun make-trampoline (codegen super body)
                           (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 +502,9 @@ (defun invoke-delegation-chain (codegen target basic-tail chain kernel)
    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 +515,13 @@ (defun invoke-delegation-chain (codegen target basic-tail chain kernel)
               (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))))