src/method-{impl,proto}.lisp: Add `sod-method-description'.

[sod] / src / method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 963f2fe..630570b 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -30,8 +30,7 @@
 
 (export 'basic-message)
 (defclass basic-message (sod-message)
-  ((argument-tail :type list :reader sod-message-argument-tail)
-   (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
+  ((argument-tail :type list :reader sod-message-argument-tail))
   (:documentation
    "Base class for built-in message classes.
 
@@ -52,9 +51,6 @@
                                 (argument-type arg))))
            (c-function-arguments (sod-message-type message)))))
 
-(define-on-demand-slot basic-message no-varargs-tail (message)
-  (reify-variable-argument-tail (sod-message-argument-tail message)))
-
 (defmethod sod-message-method-class
     ((message basic-message) (class sod-class) pset)
   (let ((role (get-property pset :role :keyword nil)))
@@ -156,6 +152,11 @@
                 ("me" (* (class (sod-method-class method))))
                 . method-args))))
 
+(defmethod sod-method-description ((method basic-direct-method))
+  (with-slots (role) method
+    (if role (string-downcase role)
+       "primary")))
+
 (defmethod sod-method-function-name ((method basic-direct-method))
   (with-slots ((class %class) role message) method
     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
@@ -248,21 +249,28 @@
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
+(defmethod method-keyword-argument-lists
+    ((method effective-method) direct-methods)
+  (with-slots (message) method
+     (and (keyword-message-p message)
+         (mapcar (lambda (m)
+                   (let ((type (sod-method-type m)))
+                     (cons (c-function-keywords type)
+                           (format nil "method for ~A on ~A (at ~A)"
+                                   message
+                                   (sod-method-class m)
+                                   (file-location m)))))
+                 direct-methods))))
+
 (defmethod shared-initialize :after
     ((method effective-method) slot-names &key direct-methods)
   (declare (ignore slot-names))
 
   ;; Set the keyword argument list.
   (with-slots (message keywords) method
-    (setf keywords (and (keyword-message-p message)
-                       (merge-keyword-lists
-                        (mapcar (lambda (m)
-                                  (let ((type (sod-method-type m)))
-                                    (cons (c-function-keywords type)
-                                          (format nil "method for ~A on ~A"
-                                                  message
-                                                  (sod-method-class m)))))
-                                direct-methods))))))
+    (setf keywords
+         (merge-keyword-lists (method-keyword-argument-lists
+                               method direct-methods)))))
 
 (export '(basic-effective-method
          effective-method-around-methods effective-method-before-methods
@@ -288,9 +296,9 @@
    using a slot reader method."))
 
 (define-on-demand-slot basic-effective-method basic-argument-names (method)
-  (let ((message (effective-method-message method)))
-    (mapcar #'argument-name
-           (sod-message-no-varargs-tail message))))
+  (let* ((message (effective-method-message method))
+        (raw-tail (sod-message-argument-tail message)))
+    (mapcar #'argument-name (reify-variable-argument-tail raw-tail))))
 
 (defmethod effective-method-function-name ((method effective-method))
   (let* ((class (effective-method-class method))
@@ -794,9 +802,11 @@
                                       *null-pointer* 0)))
               (call-next-method)))))))
 
-(defmethod compute-method-entry-functions
-    ((method simple-effective-method))
-  (if (effective-method-primary-methods method)
+(defmethod effective-method-live-p ((method simple-effective-method))
+  (effective-method-primary-methods method))
+
+(defmethod compute-method-entry-functions :around ((method effective-method))
+  (if (effective-method-live-p method)
       (call-next-method)
       nil))