src/: Improve formatting of big lambda-lists.

[sod] / src / method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index e93fb3aa1887e8f5618566e3810037d682bf46d1..6c751a4dff360cfa53d6b3f5d53e06bd369a2403 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -249,29 +249,32 @@ (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 state)
-  (with-slots (message) method
-    (and (keyword-message-p message)
-        (cons (cons (lambda (arg)
-                      (let ((class (sod-message-class message)))
-                        (info-with-location
-                         message "Type `~A' declared in message ~
-                                  definition in `~A' (here)"
-                         (argument-type arg) class)
-                        (report-inheritance-path state class)))
-                    (c-function-keywords (sod-message-type message)))
-              (mapcar (lambda (m)
-                        (cons (lambda (arg)
-                                (let ((class (sod-method-class m)))
-                                  (info-with-location
-                                   m "Type `~A' declared in ~A direct ~
-                                      method of `~A' (defined here)"
-                                   (argument-type arg)
-                                   (sod-method-description m) class)
-                                  (report-inheritance-path state class)))
-                              (c-function-keywords (sod-method-type m))))
-                      direct-methods)))))
+(defmethod sod-message-keyword-argument-lists
+    ((message sod-message) (class sod-class) direct-methods state)
+  (and (keyword-message-p message)
+       (cons (cons (lambda (arg)
+                    (let ((class (sod-message-class message)))
+                      (info-with-location
+                       message "Type `~A' declared in message ~
+                                definition in `~A' (here)"
+                       (argument-type arg) class)
+                      (report-inheritance-path state class)))
+                  (c-function-keywords (sod-message-type message)))
+            (mapcar (lambda (method)
+                      (cons (lambda (arg)
+                              (let ((class (sod-method-class method)))
+                                (info-with-location
+                                 method "Type `~A' declared in ~A direct ~
+                                         method of `~A' (defined here)"
+                                 (argument-type arg)
+                                 (sod-method-description method) class)
+                                (report-inheritance-path state class)))
+                            (c-function-keywords (sod-method-type method))))
+                    direct-methods))))
+
+(defmethod sod-message-check-methods
+    ((message sod-message) (class sod-class) direct-methods)
+  (compute-effective-method-keyword-arguments message class direct-methods))

 
 (defmethod shared-initialize :after
     ((method effective-method) slot-names &key direct-methods)
 
 (defmethod shared-initialize :after
     ((method effective-method) slot-names &key direct-methods)


@@ -282,15 +285,9 @@ (defmethod shared-initialize :after
   ;; class construction.
   (with-slots ((class %class) message keywords) method
     (setf keywords
   ;; class construction.
   (with-slots ((class %class) message keywords) method
     (setf keywords

-         (merge-keyword-lists
-          (lambda ()
-            (values class
-                    (format nil
-                            "methods for message `~A' ~
-                             applicable to class `~A'"
-                            message class)))
-          (method-keyword-argument-lists method direct-methods
-           (make-inheritance-path-reporter-state class))))))
+         (compute-effective-method-keyword-arguments message
+                                                     class
+                                                     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