+(defun fix-and-check-keyword-argument-list (list)
+ "Check the keyword argument LIST is valid; if so, fix it up and return it.
+
+ Check that the keyword arguments have distinct names. Fix the list up by
+ sorting it by keyword name."
+
+ (unless (every #'argumentp list)
+ (error "(INTERNAL) not an argument value"))
+
+ (let ((list (sort (copy-list list) #'string< :key #'argument-name)))
+ (do ((list (cdr list) (cdr list))
+ (this (car list) (car list))
+ (prev nil this))
+ ((endp list))
+ (when prev
+ (let ((this-name (argument-name this))
+ (prev-name (argument-name prev)))
+ (when (string= this-name prev-name)
+ (error "Duplicate keyword argument name `~A'" this-name)))))
+ list))
+
+(export 'merge-keyword-lists)
+(defun merge-keyword-lists (whatfn lists)
+ "Return the union of keyword argument lists.
+
+ 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.
+
+ 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.
+
+ (let ((argmap (make-hash-table :test #'equal)))
+
+ ;; Set up the table. When we find a duplicate, check that the types
+ ;; match.
+ (dolist (item lists)
+ (let ((reportfn (car 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 reportfn arg))
+ (let* ((type (argument-type arg))
+ (other-reportfn (car other-item))
+ (other (cdr other-item))
+ (other-type (argument-type other)))
+ (unless (c-type-equal-p type other-type)
+ (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))
+ (maphash (lambda (name item)
+ (declare (ignore name))
+ (push (cdr item) result))
+ argmap)
+ (fix-and-check-keyword-argument-list result))))
+