src/method-{proto,impl}.lisp: Add `:valist' method-entry role.

For each varargs message, add a new entry whose name has a `__v' suffix,
and which takes a `va_list' argument in place of the variable-length
argument list of the `nil' entry.  The `nil' entry now just sets up the
`va_list' pointer and invokes the corresponding `:valist' entry function.

This actually makes constructing the method-entry functions somewhat
cleaner, since the handling of variable argument lists is now
concentrated in the construction of a separate entry function.

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 46f268b635078d9e279cdfb889bc8e4676194245..c5785a26f80774f05efd4bf79d1c4950f624d6f9 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -380,7 +380,8 @@ (defmethod method-entry-function-type ((entry method-entry))
         (message (effective-method-message method))
         (type (sod-message-type message))
         (tail (ecase (method-entry-role entry)
-                ((nil) (sod-message-argument-tail message)))))
+                ((nil) (sod-message-argument-tail message))
+                (:valist (sod-message-no-varargs-tail message)))))
     (c-type (fun (lisp (c-type-subtype type))
                 ("me" (* (class (method-entry-chain-tail entry))))
                 . tail))))
@@ -396,6 +397,7 @@ (defmethod make-method-entries ((method basic-effective-method)
                                  :chain-head chain-head
                                  :chain-tail chain-tail)
                   entries)))
+      (when (varargs-message-p message) (make :valist))
       (make nil)
       entries)))
 
@@ -438,8 +440,9 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
                                     (mapcar #'car
                                             (sod-class-chains class))))
         (n-entries (length chain-tails))
-        (entry-args (sod-message-argument-tail message))
-        (parm-n (let ((tail (last entry-args 2)))
+        (raw-entry-args (sod-message-argument-tail message))
+        (entry-args (sod-message-no-varargs-tail message))
+        (parm-n (let ((tail (last raw-entry-args 2)))
                   (and tail (eq (cadr tail) :ellipsis) (car tail))))
         (entry-target (codegen-target codegen))
 
@@ -457,20 +460,36 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
               (ensure-var codegen "sod__obj" ilayout-type
                           (make-convert-to-ilayout-inst class
                                                         head "me"))))
-          (varargs-prologue ()
-            (ensure-var codegen *sod-ap* (c-type va-list))
-            (emit-inst codegen
-                       (make-va-start-inst *sod-ap*
-                                           (argument-name parm-n))))
-          (varargs-epilogue ()
-            (emit-inst codegen (make-va-end-inst *sod-ap*)))
           (finish-entry (tail)
             (let* ((head (sod-class-chain-head tail))
-                   (name (method-entry-function-name method head nil))
+                   (role (if parm-n :valist nil))
+                   (name (method-entry-function-name method head role))
                    (type (c-type (fun (lisp return-type)
                                       ("me" (* (class tail)))
                                       . entry-args))))
-              (codegen-pop-function codegen name type))))
+              (codegen-pop-function codegen name type)
+
+              ;; If this is a varargs method then we've made the
+              ;; `:valist' role.  Also make the `nil' role.
+              (when parm-n
+                (let ((call (make-call-inst name
+                                            (cons "me"
+                                                  (mapcar #'argument-name
+                                                          entry-args))))
+                      (main (method-entry-function-name method head nil))
+                      (main-type (c-type (fun (lisp return-type)
+                                              ("me" (* (class tail)))
+                                              . raw-entry-args))))
+                  (codegen-push codegen)
+                  (ensure-var codegen *sod-ap* (c-type va-list))
+                  (emit-inst codegen
+                             (make-va-start-inst *sod-ap*
+                                                 (argument-name parm-n)))
+                  (convert-stmts codegen entry-target return-type
+                                 (lambda (target)
+                                   (deliver-expr codegen target call)))
+                  (emit-inst codegen (make-va-end-inst *sod-ap*))
+                  (codegen-pop-function codegen main main-type))))))
 
       ;; Generate the method body.  We'll work out what to do with it later.
       (codegen-push codegen)
@@ -493,9 +512,7 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
                         (ensure-var codegen (inst-name var)
                                     (inst-type var) (inst-init var))
                         (emit-decl codegen var)))
-                  (when parm-n (varargs-prologue))
                   (emit-insts codegen insts)
-                  (when parm-n (varargs-epilogue))
                   (deliver-expr codegen entry-target result)
                   (finish-entry tail)))
 
@@ -513,15 +530,7 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
                                                       emf-arg-tail)))))
                   (dolist (tail chain-tails)
                     (setup-entry tail)
-                    (cond (parm-n
-                           (varargs-prologue)
-                           (convert-stmts codegen entry-target return-type
-                                          (lambda (target)
-                                            (deliver-expr codegen
-                                                          target call)
-                                            (varargs-epilogue))))
-                          (t
-                           (deliver-expr codegen entry-target call)))
+                    (deliver-expr codegen entry-target call)
                     (finish-entry tail)))))))
 
       (codegen-functions codegen))))

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index 78429ef93f5e4a7b6c538b003a1cfe162ca28db7..7fd08b8f48a13426c1fd04d4306671a31e140de2 100644 (file)
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -105,8 +105,10 @@ (defclass method-entry ()
 
    A vtable can contain more than one entry for the same message.  Such
    entries are distinguished by their roles.  A message always has an entry
-   with the `nil role.  No other roles are currently defined, though they may
-   be introduced by extensions.
+   with the `nil role; in addition, a varargs message also has a `:valist'
+   role, which accepts a `va_list' argument in place of the variable argument
+   listNo other roles are currently defined, though they may be introduced by
+   extensions.
 
    The boundaries between a method entry and the effective method
    is (intentionally) somewhat fuzzy.  In extreme cases, the effective method
@@ -197,7 +199,9 @@ (defgeneric method-entry-slot-name (entry)
 
 (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))
+  (:method ((entry method-entry) (role (eql nil)) name) name)
+  (:method ((entry method-entry) (role (eql :valist)) name)
+    (format nil "~A__v" name)))
 
 (export 'effective-method-basic-argument-names)
 (defgeneric effective-method-basic-argument-names (method)