X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3b2ec4790da6b3f64189a58896957ac63169dd5e..7b118f8a767addd8c869bf83506f48d28dcd7b94:/src/method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 4bf3214..e93fb3a 100644
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -152,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
@@ -245,27 +250,47 @@
 ;;; 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)
-	  (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))))
+    (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 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
+  ;; 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
-	  (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