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:
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))
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.