src/c-types-impl.lisp: Reorder `merge-keyword-lists' input lists.

[sod] / src / method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 20380a7c4b7818bf044b79403a5532847a841cda..16ae56e94a9f8462d5f1c60f538339a43e446d59 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -152,6 +152,11 @@ (define-on-demand-slot basic-direct-method function-type (method)
                 ("me" (* (class (sod-method-class method))))
                 . method-args))))
 
                 ("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
 (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


@@ -244,21 +249,30 @@ (define-on-demand-slot delegating-direct-method function-type (method)
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 

+(defmethod method-keyword-argument-lists
+    ((method effective-method) direct-methods)
+  (with-slots (message) method
+    (and (keyword-message-p message)
+        (cons (cons (format nil "message ~A (at ~A)"
+                            message (file-location message))
+                    (c-function-keywords (sod-message-type message)))
+              (mapcar (lambda (m)
+                        (cons (format nil "method for ~A on ~A (at ~A)"
+                                      message
+                                      (sod-method-class m)
+                                      (file-location m))
+                              (c-function-keywords (sod-method-type 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
 (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
 
 (export '(basic-effective-method
          effective-method-around-methods effective-method-before-methods