src/{c-types-impl,method-{proto,impl}}.lisp: Improve `merge-keyword-lists'.

  * Make the overall description of the merging site be a function (a)
    to report a file location and (b) to avoid formatting the thing if
    there isn't actually a problem.

  * Make the per-argument-list descriptions be functions so that they
    can report more than one message each.

  * Change `method-keyword-argument-lists' to report the inheritance
    path for methods involved in keyword argument conflicts.  Add an
    argument to thread through an `inheritance-path-reporter-state'
    object to make this work.

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 16e763ac6a33d6bf05e3c6403daecec1b9e931bc..89723e727158c0b284459796e8615d53aa051516 100644 (file)
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -1303,8 +1303,8 @@ method-entry-function-type
 method-entry-slot-name
   method-entry
 method-keyword-argument-lists
 method-entry-slot-name
   method-entry
 method-keyword-argument-lists

-  effective-method t
-  sod::initialization-effective-method t
+  effective-method t t
+  sod::initialization-effective-method t t

 module-dependencies
   module
 (setf module-dependencies)
 module-dependencies
   module
 (setf module-dependencies)

diff --git a/doc/clang.tex b/doc/clang.tex
index 18a8e1cfc1f41b8986f01021b840785b2c537eff..6d256ec4940a44a181aefcfdc97c3413a1add527 100644 (file)
--- a/doc/clang.tex
+++ b/doc/clang.tex
@@ -1017,13 +1017,15 @@ function type is the type of the function's return value.
   original list is not modified, but may share structure with the new list.
 \end{describe}
 
   original list is not modified, but may share structure with the new list.
 \end{describe}
 

-\begin{describe}{fun}{merge-keyword-lists @<lists> @> @<list>}
+\begin{describe}{fun}
+    {merge-keyword-lists @<what-function> @<lists> @> @<list>}

   Merge a number of keyword-argument lists together and return the result.
 
   Merge a number of keyword-argument lists together and return the result.
 

-  The @<lists> parameter is a list consisting of a number of @|(@<origin>
-  . @<args>)| pairs: in each pair, @<origin> is either nil or an object whose
-  printed representation describes the origin of the corresponding @<args>
-  list suitable for inclusion in an error message, and @<args> is a list of
+  The @<what-function> is either nil or a function designator; see below.
+
+  The @<lists> parameter is a list consisting of a number of
+  @|(@<report-function> . @<args>)| pairs: in each pair, @<report-function>
+  is either nil or a function designator, and @<args> is a list of

   \descref{argument}{cls} objects.
 
   The resulting list contains exactly one argument for each distinct argument
   \descref{argument}{cls} objects.
 
   The resulting list contains exactly one argument for each distinct argument


@@ -1031,9 +1033,29 @@ function type is the type of the function's return value.
   default value from the earliest occurrence in the input @<lists> of an
   argument with that name.
 
   default value from the earliest occurrence in the input @<lists> of an
   argument with that name.
 

-  If the same name appears multiple times with different types, an error is
-  signalled quoting the name, conflicting types, and (if non-nil) the origins
-  of the offending argument objects.
+  If the same name appears multiple times with different types, a continuable
+  error will be signalled, and one of the conflicting argument types will be
+  chosen arbitrarily.  The @<what-function> will be called to establish
+  information which will be reported to the user.  It will be called with no
+  arguments and is expected to return two values:
+  \begin{itemize}
+  \item a file location @<floc> or other object acceptable to
+    \descref{file-location}{gf}, to be used as the location of the main
+    error; and
+  \item an object @<what>, whose printed representation should be a noun
+    phrase describing the object for which the argument lists are being
+    combined.
+  \end{itemize}
+  The phrasing of the error message is `type mismatch in @<what>'.  Either,
+  or both, of @<floc> and @<what> may be nil, though this is considered poor
+  practice; if @<what-function> is nil, this is equivalent to a function
+  which returns two nil values.  Following the error, the @<report-function>s
+  for the @<args> lists containing the conflicting argument objects are
+  called, in an arbitrary order, with a single argument which is the
+  offending @|argument| object; the function is expected to issue information
+  messages (see \descref{info}{fun}) to give more detail for diagnosing the
+  conflict.  If a @<report-function> is nil, then nothing happens; this is
+  considered poor practice.

 \end{describe}
 
 \begin{describe}{fun}
 \end{describe}
 
 \begin{describe}{fun}

diff --git a/doc/layout.tex b/doc/layout.tex
index 80c264e1d9b39452fb50491bbfc2c3147f77ae78..e42b83f0cda23643c0c9f68513bf098a4a4c419d 100644 (file)
--- a/doc/layout.tex
+++ b/doc/layout.tex
@@ -233,7 +233,8 @@
 \end{describe}
 
 \begin{describe}{gf}
 \end{describe}
 
 \begin{describe}{gf}

-    {method-keyword-argument-lists @<method> @<direct-methods> @> @<list>}
+    {method-keyword-argument-lists @<method> @<direct-methods> @<state>
+      @> @<list>}

 \end{describe}
 
 \begin{describe}{gf}
 \end{describe}
 
 \begin{describe}{gf}

diff --git a/src/builtin.lisp b/src/builtin.lisp
index 77eca391e49ea79bbf09e7e14c684274273ac411..be9a8e5caca366ee583f5126fa7c6e3dffced6c0 100644 (file)
--- a/src/builtin.lisp
+++ b/src/builtin.lisp
@@ -295,15 +295,28 @@ (defmethod sod-message-effective-method-class
   'initialization-effective-method)
 
 (defmethod method-keyword-argument-lists
   'initialization-effective-method)
 
 (defmethod method-keyword-argument-lists

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

   (append (call-next-method)
          (mapcan (lambda (class)
   (append (call-next-method)
          (mapcan (lambda (class)

-                   (let ((initargs (sod-class-initargs class)))
+                   (let* ((initargs (sod-class-initargs class))
+                          (map (make-hash-table))
+                          (arglist (mapcar
+                                    (lambda (initarg)
+                                      (let ((arg (sod-initarg-argument
+                                                  initarg)))
+                                        (setf (gethash arg map) initarg)
+                                        arg))
+                                    initargs)))

                      (and initargs
                      (and initargs

-                          (list (cons (format nil "initargs for ~A"
-                                              class)
-                                      (mapcar #'sod-initarg-argument
-                                              initargs))))))
+                          (list (cons (lambda (arg)
+                                        (info-with-location
+                                         (gethash arg map)
+                                         "Type `~A' from initarg ~
+                                          in class `~A' (here)"
+                                         (argument-type arg) class)
+                                        (report-inheritance-path
+                                         state class))
+                                      arglist)))))

                  (sod-class-precedence-list
                   (effective-method-class method)))))
 
                  (sod-class-precedence-list
                   (effective-method-class method)))))
 

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index e87964c66a09f924b3e0ad9922f5a1514dac12ec..255a470227f7629487e4b7e3077cdd2abc93ec71 100644 (file)
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -589,22 +589,38 @@ (defun fix-and-check-keyword-argument-list (list)
     list))
 
 (export 'merge-keyword-lists)
     list))
 
 (export 'merge-keyword-lists)

-(defun merge-keyword-lists (lists)
+(defun merge-keyword-lists (whatfn lists)

   "Return the union of keyword argument lists.
 
   "Return the union of keyword argument lists.
 

-   The LISTS parameter consists of pairs (WHAT . ARGS), where WHAT is either
-   nil or a printable object describing the origin of this argument list
-   suitable for inclusion in an error message, and ARGS is a list of
-   `argument' objects.
+   The WHATFN is either nil or a designator for a function (see below).
+
+   The LISTS parameter consists of pairs (REPORTFN . ARGS), where REPORTFN is
+   either nil or a designator for a function (see below); and and ARGS is a
+   list of `argument' objects.

 
    The resulting list contains exactly one argument for each distinct
    argument name appearing in the input lists; this argument will contain the
    default value corresponding to the name's earliest occurrence in the input
    LISTS.
 
 
    The resulting list contains exactly one argument for each distinct
    argument name appearing in the input lists; this argument will contain the
    default value corresponding to the name's earliest occurrence in the input
    LISTS.
 

-   If the same name appears in multiple input lists with different types, an
-   error is signalled; this error will quote the origins of a representative
-   conflicting pair of arguments."
+   If the same name appears in multiple input lists with different types, a
+   continuable error is signalled.
+
+   The WHATFN function is given no arguments, and is expected to return a
+   file location (or other object convertible with `file-location'), and a
+   string (or other printable object) describing the site at which the
+   keyword argument lists are being merged or nil; a mismatch error will be
+   reported as being at the location returned by WHATFN, and the description
+   will be included in the error message.  A nil WHATFN is equivalent to a
+   function which returns a nil location and description, though this is
+   considered poor practice.
+
+   The REPORTFN is given a single argument ARG, which is one of the
+   conflicting `argument' objects found in the REPORTFN's corresponding
+   argument list: the REPORTFN is expected to issue additional `info'
+   messages to help the user diagnose the problem.  The (common) name of the
+   argument has already been reported.  A nil REPORTFN is equivalent to one
+   which does nothing, though this is considered poor practice."

 
   ;; The easy way through all of this is with a hash table mapping argument
   ;; names to (WHAT . ARG) pairs.
 
   ;; The easy way through all of this is with a hash table mapping argument
   ;; names to (WHAT . ARG) pairs.


@@ -614,23 +630,28 @@ (defun merge-keyword-lists (lists)
     ;; Set up the table.  When we find a duplicate, check that the types
     ;; match.
     (dolist (item lists)
     ;; Set up the table.  When we find a duplicate, check that the types
     ;; match.
     (dolist (item lists)

-      (let ((what (car item))
+      (let ((reportfn (car item))

            (args (cdr item)))
        (dolist (arg args)
          (let* ((name (argument-name arg))
                 (other-item (gethash name argmap)))
            (if (null other-item)
            (args (cdr item)))
        (dolist (arg args)
          (let* ((name (argument-name arg))
                 (other-item (gethash name argmap)))
            (if (null other-item)

-               (setf (gethash name argmap) (cons what arg))
+               (setf (gethash name argmap) (cons reportfn arg))

                (let* ((type (argument-type arg))
                (let* ((type (argument-type arg))

-                      (other-what (car other-item))
+                      (other-reportfn (car other-item))

                       (other (cdr other-item))
                       (other-type (argument-type other)))
                  (unless (c-type-equal-p type other-type)
                       (other (cdr other-item))
                       (other-type (argument-type other)))
                  (unless (c-type-equal-p type other-type)

-                   (error "Type mismatch for keyword argument `~A': ~
-                           ~A~@[ (~A)~] doesn't match ~A~@[ (~A)~]"
-                          name
-                          type what
-                          other-type other-what))))))))
+                   (multiple-value-bind (floc desc)
+                       (if whatfn (funcall whatfn) (values nil nil))
+                     (cerror*-with-location floc
+                                            "Type mismatch for keyword ~
+                                             argument `~A'~@[ in ~A~]"
+                                            name desc)
+                     (when reportfn
+                       (funcall reportfn arg))
+                     (when other-reportfn
+                       (funcall other-reportfn other))))))))))

 
     ;; Now it's just a matter of picking the arguments out again.
     (let ((result nil))
 
     ;; Now it's just a matter of picking the arguments out again.
     (let ((result nil))

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

diff --git a/src/method-proto.lisp b/src/method-proto.lisp
index a9865845f0fdf423eb6f6bb391d64e40c2b39853..f7f1f474b8a9e93dfee6d60ac9ce9f6d2e4d6a6d 100644 (file)
--- a/src/method-proto.lisp
+++ b/src/method-proto.lisp
@@ -64,13 +64,19 @@ (defgeneric primary-method-class (message)
    This protocol is used by `simple-message' subclasses."))
 
 (export 'method-keyword-argument-lists)
    This protocol is used by `simple-message' subclasses."))
 
 (export 'method-keyword-argument-lists)

-(defgeneric method-keyword-argument-lists (method direct-methods)
+(defgeneric method-keyword-argument-lists (method direct-methods state)

   (:documentation
    "Returns a list of keyword argument lists to be merged.
 
    This should return a list suitable for passing to `merge-keyword-lists',
   (:documentation
    "Returns a list of keyword argument lists to be merged.
 
    This should return a list suitable for passing to `merge-keyword-lists',

-   i.e., each element should be a pair consisting of a string describing the
-   source of the argument list, and a list of `argument' objects."))
+   i.e., each element should be a pair consisting of a function describing
+   the source of the argument list (returning location and description), and
+   a list of `argument' objects.
+
+   The METHOD is the effective method being processed; DIRECT-METHODS is the
+   complete list of applicable direct methods (most specific first); and
+   STATE is an `inheritance-path-reporter-state' object which can be used by
+   the returned reporting functions."))

 
 (export 'compute-sod-effective-method)
 (defgeneric compute-sod-effective-method (message class)
 
 (export 'compute-sod-effective-method)
 (defgeneric compute-sod-effective-method (message class)