X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3e166443f7ed632f0a8b3d0e680c2afcc265d56f..e046c3f65a8f7241889fb9b6005aac21e2aad1a8:/src/utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 4b0eeba..72423fd 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -446,11 +446,13 @@
   (:documentation
    "Reports an inconsistency in the arguments passed to `merge-lists'.")
   (:report (lambda (condition stream)
-	     (format stream "Merge inconsistency: failed to decide among ~A."
+	     (format stream "Merge inconsistency: failed to decide between ~
+			     ~{~#[~;~A~;~A and ~A~:;~
+				  ~@{~A, ~#[~;and ~A~]~}~]~}"
 		     (merge-error-candidates condition)))))
 
 (export 'merge-lists)
-(defun merge-lists (lists &key pick (test #'eql))
+(defun merge-lists (lists &key pick (test #'eql) (present #'identity))
   "Return a merge of the given LISTS.
 
    The resulting list contains the items of the given LISTS, with duplicates
@@ -458,7 +460,10 @@
    the input LISTS in the sense that if A precedes B in some input list then
    A will also precede B in the output list.  If the lists aren't consistent
    (e.g., some list contains A followed by B, and another contains B followed
-   by A) then an error of type `inconsistent-merge-error' is signalled.
+   by A) then an error of type `inconsistent-merge-error' is signalled.  The
+   offending items are filtered for presentation through the PRESENT function
+   before being attached to the condition, so as to produce a more useful
+   diagnostic message.
 
    Item equality is determined by TEST.
 
@@ -500,7 +505,7 @@
 			      candidates))
 	   (winner (cond ((null leasts)
 			  (error 'inconsistent-merge-error
-				 :candidates candidates))
+				 :candidates (mapcar present candidates)))
 			 ((null (cdr leasts))
 			  (car leasts))
 			 (pick
@@ -828,6 +833,30 @@
 		(setf (,to object) value))))))
 
 ;;;--------------------------------------------------------------------------
+;;; Condition and error utilities.
+
+(export 'designated-condition)
+(defun designated-condition (default-type datum arguments
+			     &key allow-pointless-arguments)
+  "Return the condition designated by DATUM and ARGUMENTS.
+
+   DATUM and ARGUMENTS together are a `condition designator' of (some
+   supertype of) DEFAULT-TYPE; return the condition so designated."
+  (typecase datum
+    (condition
+     (unless (or allow-pointless-arguments (null arguments))
+       (error "Argument list provided with specific condition"))
+     datum)
+    (symbol
+     (apply #'make-condition datum arguments))
+    ((or string function)
+     (make-condition default-type
+		     :format-control datum
+		     :format-arguments arguments))
+    (t
+     (error "Unexpected condition designator datum ~S" datum))))
+
+;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.
 
 (export 'default-slot)