("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
;;;--------------------------------------------------------------------------
;;; 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 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))))))
+ ;; 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
+ (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