src/: Allow methods to have more than one entry each in a vtable.

The entries are assigned distinct `roles' to distinguish them.  Each
role can have a different type.  To accommodate this a number of changes
are made to the API.  Note that no roles other than the standard `nil'
role are currently defined, so none of this change should have any
externally observable effect.

  * The `make-method-entry' method is replaced by `make-method-entries',
    which returns a list of entry objects.  The standard method on
    `compute-vtmsgs' collects these together into a big list.

  * Slots in the `vtmsgs' structure are now given names by the method
    entries directly, rather than being named after their messages.
    There is a new generic function `method-entry-slot-name' to make
    this work, and a little protocol `method-entry-slot-name-by-role' to
    make extending this machinery easy.

  * The `message-macro-name' function now takes a method-entry rather
    than a message, because each entry needs its own macro.

  * The `method-entry-function-name' function has grown an additional
    `role' argument.  The standard method inserts a non-nil role name in
    an unimaginative manner.

  * The standard method on `method-entry-function-type' now inspects the
    entry role, but its behaviour is unchanged except to check that the
    role is nil.

diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp
index 3a5b5cd..950db2b 100644 (file)
--- a/src/class-layout-impl.lisp
+++ b/src/class-layout-impl.lisp
@@ -104,9 +104,10 @@
 
 (defmethod print-object ((entry method-entry) stream)
   (maybe-print-unreadable-object (entry stream :type t)
-    (format stream "~A:~A"
+    (format stream "~A:~A~@[ ~S~]"
            (method-entry-effective-method entry)
-           (sod-class-nickname (method-entry-chain-head entry)))))
+           (sod-class-nickname (method-entry-chain-head entry))
+           (method-entry-role entry))))
 
 (defmethod compute-sod-effective-method
     ((message sod-message) (class sod-class))
@@ -229,17 +230,17 @@
      (subclass sod-class)
      (chain-head sod-class)
      (chain-tail sod-class))
-  (flet ((make-entry (message)
+  (flet ((make-entries (message)
           (let ((method (find message
                               (sod-class-effective-methods subclass)
                               :key #'effective-method-message)))
-            (make-method-entry method chain-head chain-tail))))
+            (make-method-entries method chain-head chain-tail))))
     (make-instance 'vtmsgs
                   :class class
                   :subclass subclass
                   :chain-head chain-head
                   :chain-tail chain-tail
-                  :entries (mapcar #'make-entry
+                  :entries (mapcan #'make-entries
                                    (sod-class-messages class)))))
 
 ;;; class-pointer

diff --git a/src/class-output.lisp b/src/class-output.lisp
index d6ead49..2ab6363 100644 (file)
--- a/src/class-output.lisp
+++ b/src/class-output.lisp
@@ -125,16 +125,14 @@
         (dolist (entry (vtmsgs-entries vtmsgs))
           (let* ((type (method-entry-function-type entry))
                  (args (c-function-arguments type))
-                 (method (method-entry-effective-method entry))
-                 (message (effective-method-message method))
                  (in-names nil) (out-names nil) (varargsp nil) (me "me"))
             (do ((args args (cdr args)))
                 ((endp args))
-              (let* ((raw-name (argument-name (car args)))
+              (let* ((raw-name (princ-to-string (argument-name (car args))))
                      (name (if (find raw-name
                                      (list "_vt"
                                            (sod-class-nickname class)
-                                           (sod-message-name message))
+                                           (method-entry-slot-name entry))
                                      :test #'string=)
                                (format nil "sod__a_~A" raw-name)
                                raw-name)))
@@ -151,11 +149,11 @@
               (format stream "#if __STDC_VERSION__ >= 199901~%"))
             (format stream "#define ~A(~{~A~^, ~}) ~
                                   ~A->_vt->~A.~A(~{~A~^, ~})~%"
-                    (message-macro-name class message)
+                    (message-macro-name class entry)
                     (nreverse in-names)
                     me
                     (sod-class-nickname class)
-                    (sod-message-name message)
+                    (method-entry-slot-name entry)
                     (nreverse out-names))
             (when varargsp
               (format stream "#endif~%"))))
@@ -348,7 +346,7 @@
     (sequence-output (stream sequencer)
       ((class :vtmsgs (sod-message-class message) :slots)
        (pprint-logical-block (stream nil :prefix "  " :suffix ";")
-        (pprint-c-type pointer-type stream (sod-message-name message)))
+        (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
        (terpri stream)))))
 
 (defmethod hook-output progn ((cptr class-pointer)
@@ -541,15 +539,15 @@ const struct ~A ~A__classobj = {~%"
 (defmethod hook-output progn ((entry method-entry)
                              (reason (eql :c))
                              sequencer)
-  (with-slots (method chain-head chain-tail) entry
+  (with-slots (method chain-head chain-tail role) entry
     (let* ((message (effective-method-message method))
           (class (effective-method-class method))
           (super (sod-message-class message)))
       (sequence-output (stream sequencer)
        ((class :vtable chain-head :vtmsgs super :slots)
         (format stream "    /* ~19@A = */ ~A,~%"
-                (sod-message-name message)
-                (method-entry-function-name method chain-head)))))))
+                (method-entry-slot-name entry)
+                (method-entry-function-name method chain-head role)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Filling in the class object.

diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp
index 5a74bcb..f00bc64 100644 (file)
--- a/src/class-utilities.lisp
+++ b/src/class-utilities.lisp
@@ -198,7 +198,7 @@
   (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
 
 (export 'message-macro-name)
-(defun message-macro-name (class message)
-  (format nil "~A_~A" class (sod-message-name message)))
+(defun message-macro-name (class entry)
+  (format nil "~A_~A" class (method-entry-slot-name entry)))
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 9dd75b4..46f268b 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -355,33 +355,49 @@
    effective method out into its own function.")
 
 (defmethod method-entry-function-name
-    ((method effective-method) (chain-head sod-class))
+    ((method effective-method) (chain-head sod-class) role)
   (let* ((class (effective-method-class method))
         (message (effective-method-message method))
         (message-class (sod-message-class message)))
     (if (or (not (slot-boundp method 'functions))
            (slot-value method 'functions))
-       (format nil "~A__mentry_~A__~A__chain_~A"
-               class
+       (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A"
+               class role
                (sod-class-nickname message-class)
                (sod-message-name message)
                (sod-class-nickname chain-head))
        0)))
 
+(defmethod method-entry-slot-name ((entry method-entry))
+  (let* ((method (method-entry-effective-method entry))
+        (message (effective-method-message method))
+        (name (sod-message-name message))
+        (role (method-entry-role entry)))
+    (method-entry-slot-name-by-role entry role name)))
+
 (defmethod method-entry-function-type ((entry method-entry))
   (let* ((method (method-entry-effective-method entry))
         (message (effective-method-message method))
-        (type (sod-message-type message)))
+        (type (sod-message-type message))
+        (tail (ecase (method-entry-role entry)
+                ((nil) (sod-message-argument-tail message)))))
     (c-type (fun (lisp (c-type-subtype type))
                 ("me" (* (class (method-entry-chain-tail entry))))
-                . (sod-message-argument-tail message)))))
-
-(defmethod make-method-entry ((method basic-effective-method)
-                             (chain-head sod-class) (chain-tail sod-class))
-  (make-instance 'method-entry
-                :method method
-                :chain-head chain-head
-                :chain-tail chain-tail))
+                . tail))))
+
+(defmethod make-method-entries ((method basic-effective-method)
+                               (chain-head sod-class)
+                               (chain-tail sod-class))
+  (let ((entries nil)
+       (message (effective-method-message method)))
+    (flet ((make (role)
+            (push (make-instance 'method-entry
+                                 :method method :role role
+                                 :chain-head chain-head
+                                 :chain-tail chain-tail)
+                  entries)))
+      (make nil)
+      entries)))
 
 (defmethod compute-method-entry-functions ((method basic-effective-method))
 
@@ -450,7 +466,7 @@
             (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))
+                   (name (method-entry-function-name method head nil))
                    (type (c-type (fun (lisp return-type)
                                       ("me" (* (class tail)))
                                       . entry-args))))

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index 8b3822a..78429ef 100644 (file)
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -85,14 +85,16 @@
    (chain-head :initarg :chain-head :type sod-class
               :reader method-entry-chain-head)
    (chain-tail :initarg :chain-tail :type sod-class
-              :reader method-entry-chain-tail))
+              :reader method-entry-chain-tail)
+   (role :initarg :role :type (or :keyword null) :reader method-entry-role))
   (:documentation
    "An entry point into an effective method.
 
-   Specifically, this is the entry point to the effective method METHOD
-   invoked via the vtable for the chain headed by CHAIN-HEAD.  The CHAIN-TAIL
-   is the most specific class on this chain; this is useful because we can
-   reuse the types of method entries from superclasses on non-primary chains.
+   Specifically, this is the entry point to the effective METHOD invoked via
+   the vtable for the chain headed by CHAIN-HEAD, and serving the given ROLE.
+   The CHAIN-TAIL is the most specific class on this chain; this is useful
+   because we can reuse the types of method entries from superclasses on
+   non-primary chains.
 
    Each effective method may have several different method entries, because
    an effective method can be called via vtables attached to different
@@ -101,16 +103,22 @@
    job of the method entry to adjust the instance pointers correctly for the
    rest of the effective method.
 
+   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.
+
    The boundaries between a method entry and the effective method
    is (intentionally) somewhat fuzzy.  In extreme cases, the effective method
    may not exist at all as a distinct entity in the output because its
    content is duplicated in all of the method entry functions.  This is left
    up to the effective method protocol."))
 
-(export 'make-method-entry)
-(defgeneric make-method-entry (effective-method chain-head chain-tail)
+(export 'make-method-entries)
+(defgeneric make-method-entries (effective-method chain-head chain-tail)
   (:documentation
-   "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
+   "Return a list of `method-entry' objects for an EFFECTIVE-METHOD called
+   via CHAIN-HEAD.
 
    There is no default method for this function.  (Maybe when the
    effective-method/method-entry output protocol has settled down I'll know
@@ -180,6 +188,17 @@
   (:documentation
    "Return the C function type for a method entry."))
 
+(export 'method-entry-slot-name)
+(defgeneric method-entry-slot-name (entry)
+  (:documentation
+   "Return the `vtmsgs' slot name for a method entry.
+
+   The default method indirects through `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))
+
 (export 'effective-method-basic-argument-names)
 (defgeneric effective-method-basic-argument-names (method)
   (:documentation
@@ -312,7 +331,8 @@
         (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))
+                       (cons (make-argument *sod-ap*
+                                            (c-type va-list))
                              (butlast raw-args))
                        raw-args)))
     (codegen-push codegen)
@@ -332,13 +352,13 @@
    "Returns the function name of an effective method."))
 
 (export 'method-entry-function-name)
-(defgeneric method-entry-function-name (method chain-head)
+(defgeneric method-entry-function-name (method chain-head role)
   (:documentation
    "Returns the function name of a method entry.
 
-   The method entry is given as an effective method/chain-head pair, rather
-   than as a method entry object because we want the function name before
-   we've made the entry object."))
+   The method entry is given as an effective method/chain-head/role triple,
+   rather than as a method entry object because we want the function name
+   before we've made the entry object."))
 
 (export 'compute-method-entry-functions)
 (defgeneric compute-method-entry-functions (method)