src/module-parse.lisp: Improve error recovery for `typename' items.

[sod] / src / method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 16ae56e94a9f8462d5f1c60f538339a43e446d59..5ea09e36c67535dbe6b451a45fd18c289548e48a 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -250,17 +250,26 @@ (define-on-demand-slot delegating-direct-method function-type (method)
 ;;; Effective method classes.
 
 (defmethod method-keyword-argument-lists
 ;;; Effective method classes.
 
 (defmethod method-keyword-argument-lists

-    ((method effective-method) direct-methods)
+    ((method effective-method) direct-methods state)

   (with-slots (message) method
     (and (keyword-message-p message)
   (with-slots (message) method
     (and (keyword-message-p message)

-        (cons (cons (format nil "message ~A (at ~A)"
-                            message (file-location 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)
                     (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))
+                        (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)))))
 
                               (c-function-keywords (sod-method-type m))))
                       direct-methods)))))
 


@@ -268,11 +277,20 @@ (defmethod shared-initialize :after
     ((method effective-method) slot-names &key direct-methods)
   (declare (ignore slot-names))
 
     ((method effective-method) slot-names &key direct-methods)
   (declare (ignore slot-names))
 

-  ;; Set the keyword argument list.
-  (with-slots (message keywords) method
+  ;; Set the keyword argument list.  Blame the class as a whole for mismatch
+  ;; errors, because they're fundamentally a non-local problem about the
+  ;; class construction.
+  (with-slots ((class %class) message keywords) method

     (setf keywords
     (setf keywords

-         (merge-keyword-lists (method-keyword-argument-lists
-                               method direct-methods)))))
+         (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))))))

 
 (export '(basic-effective-method
          effective-method-around-methods effective-method-before-methods
 
 (export '(basic-effective-method
          effective-method-around-methods effective-method-before-methods