(: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
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.
candidates))
(winner (cond ((null leasts)
(error 'inconsistent-merge-error
- :candidates candidates))
+ :candidates (mapcar present candidates)))
((null (cdr leasts))
(car leasts))
(pick
(multiple-value-call func-b (apply func-a args)))))
(reduce #'compose1 more-functions :initial-value function)))
+;;;--------------------------------------------------------------------------
+;;; Variables.
+
+(export 'defvar-unbound)
+(defmacro defvar-unbound (var doc)
+ "Make VAR a special variable with documentation DOC, but leave it unbound."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar ,var)
+ (setf (documentation ',var 'variable) ',doc)
+ ',var))
+
;;;--------------------------------------------------------------------------
;;; Symbols.
`((defun (setf ,from) (value object)
(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.