src/utilities.lisp: Convert merge candidates to presentation form on the fly.

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 0415a90..4935f8b 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -82,7 +82,7 @@
           form))))
 
 (export 'once-only)
-(defmacro once-only (binds &body body)
+(defmacro once-only ((&rest binds) &body body)
   "Macro helper for preventing repeated evaluation.
 
    The syntax is actually hairier than shown:
@@ -526,17 +526,21 @@
                         (cdddr neigh-record) best-path)))))))
     dead))
 
-(export '(inconsistent-merge-error merge-error-candidates))
+(export '(inconsistent-merge-error
+         merge-error-candidates merge-error-present-function))
 (define-condition inconsistent-merge-error (error)
   ((candidates :initarg :candidates
-              :reader merge-error-candidates))
+              :reader merge-error-candidates)
+   (present :initarg :present :initform #'identity
+           :reader merge-error-present-function))
   (:documentation
    "Reports an inconsistency in the arguments passed to `merge-lists'.")
   (:report (lambda (condition stream)
             (format stream "Merge inconsistency: failed to decide between ~
                             ~{~#[~;~A~;~A and ~A~:;~
                                  ~@{~A, ~#[~;and ~A~]~}~]~}"
-                    (merge-error-candidates condition)))))
+                    (mapcar (merge-error-present-function condition)
+                            (merge-error-candidates condition))))))
 
 (export 'merge-lists)
 (defun merge-lists (lists &key pick (test #'eql) (present #'identity))
@@ -563,9 +567,10 @@
    candidates list if and only if an occurrence of A appears in an earlier
    input list than any occurrence of item B.  (This completely determines the
    order of the candidates: it is not possible that two candidates appear in
-   the same input list would resolve the ambiguity between them.)  If PICK is
-   omitted then the item chosen is the one appearing in the earliest of the
-   input lists: i.e., effectively, the default PICK function is
+   the same input list, since that would resolve the ambiguity between them.)
+   If PICK is omitted then the item chosen is the one appearing in the
+   earliest of the input lists: i.e., effectively, the default PICK function
+   is
 
        (lambda (candidates output-so-far)
          (declare (ignore output-so-far))
@@ -592,7 +597,8 @@
                              candidates))
           (winner (cond ((null leasts)
                          (error 'inconsistent-merge-error
-                                :candidates (mapcar present candidates)))
+                                :candidates candidates
+                                :present present))
                         ((null (cdr leasts))
                          (car leasts))
                         (pick
@@ -678,6 +684,42 @@
          items
          :initial-value nil))
 
+(export 'find-duplicates)
+(defun find-duplicates (report sequence &key (key #'identity) (test #'eql))
+  "Call REPORT on each pair of duplicate items in SEQUENCE.
+
+   Duplicates are determined according to the KEY and TEST funcitons."
+  (when (symbolp test) (setf test (symbol-function test)))
+  (cond ((zerop (length sequence)) nil)
+       ((or (eq test #'eq)
+            (eq test #'eql)
+            (eq test #'equal)
+            (eq test #'equalp))
+        (let ((seen (make-hash-table :test test)))
+          (map nil (lambda (item)
+                     (let ((k (funcall key item)))
+                       (multiple-value-bind (previous matchp)
+                           (gethash k seen)
+                         (if matchp (funcall report item previous)
+                             (setf (gethash k seen) item)))))
+               sequence)))
+       ((listp sequence)
+        (mapl (lambda (tail)
+                (let* ((item (car tail))
+                       (rest (cdr tail))
+                       (match (member (funcall key item) rest
+                                      :test test :key key)))
+                  (when match (funcall report item (car match)))))
+              sequence))
+       ((vectorp sequence)
+        (dotimes (i (length sequence))
+          (let* ((item (aref sequence i))
+                 (pos (position (funcall key item) sequence
+                                :key key :test test :start (1+ i))))
+            (when pos (funcall report item (aref sequence pos))))))
+       (t
+        (error 'type-error :datum sequence :expected-type 'sequence))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Strings and characters.
 
@@ -972,6 +1014,30 @@
     (t
      (error "Unexpected condition designator datum ~S" datum))))
 
+(export 'simple-control-error)
+(define-condition simple-control-error (control-error simple-error)
+  ())
+
+(export 'invoke-associated-restart)
+(defun invoke-associated-restart (restart condition &rest arguments)
+  "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS.
+
+   Find an active restart designated by RESTART; if CONDITION is not nil,
+   then restrict the search to restarts associated with CONDITION, and
+   restarts not associated with any condition.  If no such restart is found
+   then signal an error of type `control-error'; otherwise invoke the restart
+   with the given ARGUMENTS."
+  (apply #'invoke-restart
+        (or (find-restart restart condition)
+            (error 'simple-control-error
+                   :format-control "~:[Restart ~S is not active~;~
+                                       No active `~(~A~)' restart~]~
+                                    ~@[ for condition ~S~]"
+                   :format-arguments (list (symbolp restart)
+                                           restart
+                                           condition)))
+        arguments))
+
 ;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.