X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/f7b60deb3e34c4655af26ac879a8d1f146209730..4faea17df1052a4c4f44f75b6ed537ebe9598c24:/src/utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 0f6a54b..bdcdf80 100644
--- 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
@@ -645,16 +651,17 @@
 						   (symbol-name name) "-")))
 			   cat-names))
 	 (items-var (gensym "ITEMS-")))
-    `(let ((,items-var ,items)
-	   ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
-       (dolist (,itemvar ,items-var)
-	 (let* ,bind
-	   (cond ,@(mapcar (lambda (cat-match-form cat-var)
-			     `(,cat-match-form
-			       (push ,itemvar ,cat-var)))
-			   cat-match-forms cat-vars)
-		 ,@(and (not (member t cat-match-forms))
-			`((t (error "Failed to categorize ~A" ,itemvar)))))))
+    `(let (,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
+       (let ((,items-var ,items))
+	 (dolist (,itemvar ,items-var)
+	   (let* ,bind
+	     (cond ,@(mapcar (lambda (cat-match-form cat-var)
+			       `(,cat-match-form
+				 (push ,itemvar ,cat-var)))
+			     cat-match-forms cat-vars)
+		   ,@(and (not (member t cat-match-forms))
+			  `((t (error "Failed to categorize ~A"
+				      ,itemvar))))))))
        (let ,(mapcar (lambda (name var)
 		       `(,name (nreverse ,var)))
 		     cat-names cat-vars)
@@ -678,6 +685,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.
 
@@ -996,6 +1039,61 @@
 					    condition)))
 	 arguments))
 
+(export '(enclosing-condition enclosed-condition))
+(define-condition enclosing-condition (condition)
+  ((%enclosed-condition :initarg :condition :type condition
+			:reader enclosed-condition))
+  (:documentation
+   "A condition which encloses another condition
+
+   This is useful if one wants to attach additional information to an
+   existing condition.  The enclosed condition can be obtained using the
+   `enclosed-condition' function.")
+  (:report (lambda (condition stream)
+	     (princ (enclosed-condition condition) stream))))
+
+(export 'information)
+(define-condition information (condition)
+  ())
+
+(export 'simple-information)
+(define-condition simple-information (simple-condition information)
+  ())
+
+(export 'info)
+(defun info (datum &rest arguments)
+  "Report some useful diagnostic information.
+
+   Establish a simple restart named `noted', and signal the condition of type
+   `information' designated by DATUM and ARGUMENTS.  Return non-nil if the
+   restart was invoked, otherwise nil."
+  (restart-case
+      (signal (designated-condition 'simple-information datum arguments))
+    (noted () :report "Noted." t)))
+
+(export 'noted)
+(defun noted (&optional condition)
+  "Invoke the `noted' restart, possibly associated with the given CONDITION."
+  (invoke-associated-restart 'noted condition))
+
+(export 'promiscuous-cerror)
+(defun promiscuous-cerror (continue-string datum &rest arguments)
+  "Like standard `cerror', but robust against sneaky changes of conditions.
+
+   It seems that `cerror' (well, at least the version in SBCL) is careful
+   to limit its restart to the specific condition it signalled.  But that's
+   annoying, because `sod-parser:with-default-error-location' substitutes
+   different conditions carrying the error-location information."
+  (restart-case (apply #'error datum arguments)
+    (continue ()
+      :report (lambda (stream)
+		(apply #'format stream continue-string datum arguments))
+      nil)))
+
+(export 'cerror*)
+(defun cerror* (datum &rest arguments)
+  (apply #'promiscuous-cerror "Continue" datum arguments))
+
 ;;;--------------------------------------------------------------------------
 ;;; CLOS hacking.