src/utilities.lisp, src/class-finalize-impl.lisp: Add `find-duplicates'.

Replace the internal `check-list' function in `check-sod-class' with a
proper, if strangely shaped, utility function.

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 63e0abc..4b3c490 100644 (file)
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -2310,6 +2310,7 @@ utilities.lisp
   dosequence                                    macro
   sb-mop:eql-specializer                        class
   sb-mop:eql-specializer-object                 generic
+  find-duplicates                               function
   frob-identifier                               function
   sb-mop:generic-function-methods               generic setf
   inconsistent-merge-error                      class

diff --git a/doc/misc.tex b/doc/misc.tex
index 8f9a69c..f23d6a0 100644 (file)
--- a/doc/misc.tex
+++ b/doc/misc.tex
@@ -159,11 +159,16 @@ These symbols are defined in the @|sod-utilities| package.
 \end{describe}
 
 \begin{describe}{fun}
+    {find-duplicates @<report> @<sequence> \&key :identity :test}
+\end{describe}
+
+\begin{describe}{fun}
     {frob-identifier @<string> \&key :swap-case :swap-hyphen
       @> @<frobbed-string>}
 \end{describe}
 
-\begin{describe}{fun}{whitespace-char-p @<character> @> @<generic-function>}
+\begin{describe}{fun}
+    {whitespace-char-p @<character> @> @<generalized-boolean>}
 \end{describe}
 
 \begin{describe}{fun}

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 2978bd4..320dabe 100644 (file)
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -380,14 +380,7 @@
     (check-list (sod-class-slots class) "slot" #'sod-slot-name))
 
   ;; Check that the class doesn't define conflicting things.
-  (labels ((check-list (list keyfunc complain)
-            (let ((seen (make-hash-table :test #'equal)))
-              (dolist (item list)
-                (let* ((key (funcall keyfunc item))
-                       (found (gethash key seen)))
-                  (if found (funcall complain item found)
-                      (setf (gethash key seen) item))))))
-          (simple-previous (previous)
+  (labels ((simple-previous (previous)
             (info-with-location previous "Previous definition was here"))
           (simple-complain (what namefunc)
             (lambda (item previous)
@@ -397,53 +390,57 @@
               (simple-previous previous))))
 
     ;; Make sure direct slots have distinct names.
-    (check-list (sod-class-slots class) #'sod-slot-name
-               (simple-complain "slot name" #'sod-slot-name))
+    (find-duplicates (simple-complain "slot name" #'sod-slot-name)
+                    (sod-class-slots class) :key #'sod-slot-name)
 
     ;; Make sure there's at most one initializer for each slot.
     (flet ((check-initializer-list (list kind)
-            (check-list list #'sod-initializer-slot
-                        (lambda (initializer previous)
-                          (let ((slot
-                                 (sod-initializer-slot initializer)))
-                            (cerror*-with-location initializer
-                                                   "Duplicate initializer ~
-                                                    for ~A slot `~A' ~
-                                                    in class `~A'"
-                                                   kind slot class)
-                            (simple-previous previous))))))
+            (find-duplicates (lambda (initializer previous)
+                               (let ((slot
+                                      (sod-initializer-slot initializer)))
+                                 (cerror*-with-location initializer
+                                                        "Duplicate ~
+                                                         initializer ~
+                                                         for ~A slot `~A' ~
+                                                         in class `~A'"
+                                                        kind slot class)
+                                 (simple-previous previous)))
+                             list :key #'sod-initializer-slot)))
       (check-initializer-list (sod-class-instance-initializers class)
                              "instance")
       (check-initializer-list (sod-class-class-initializers class)
                              "class"))
 
     ;; Make sure messages have distinct names.
-    (check-list (sod-class-messages class) #'sod-message-name
-               (simple-complain "message name" #'sod-message-name))
+    (find-duplicates (simple-complain "message name" #'sod-message-name)
+                    (sod-class-messages class) :key #'sod-message-name)
 
     ;; Make sure methods are sufficiently distinct.
-    (check-list (sod-class-methods class) #'sod-method-function-name
-               (lambda (method previous)
-                 (cerror*-with-location method
-                                        "Duplicate ~A direct method ~
-                                         for message `~A' in classs `~A'"
-                                        (sod-method-description method)
-                                        (sod-method-message method)
-                                        class)
-                 (simple-previous previous)))
+    (find-duplicates (lambda (method previous)
+                      (cerror*-with-location method
+                                             "Duplicate ~A direct method ~
+                                              for message `~A' ~
+                                              in classs `~A'"
+                                             (sod-method-description method)
+                                             (sod-method-message method)
+                                             class)
+                      (simple-previous previous))
+                    (sod-class-methods class)
+                    :key #'sod-method-function-name :test #'equal)
 
     ;; Make sure superclasses have distinct nicknames.
     (let ((state (make-inheritance-path-reporter-state class)))
-      (check-list (sod-class-precedence-list class) #'sod-class-nickname
-                 (lambda (super previous)
-                   (cerror*-with-location class
-                                          "Duplicate nickname `~A' ~
-                                           in superclasses of `~A': ~
-                                           used by `~A' and `~A'"
-                                          (sod-class-nickname super)
-                                          class super previous)
-                   (report-inheritance-path state super)
-                   (report-inheritance-path state previous)))))
+      (find-duplicates (lambda (super previous)
+                        (cerror*-with-location class
+                                               "Duplicate nickname `~A' ~
+                                                in superclasses of `~A': ~
+                                                used by `~A' and `~A'"
+                                               (sod-class-nickname super)
+                                               class super previous)
+                        (report-inheritance-path state super)
+                        (report-inheritance-path state previous))
+                      (sod-class-precedence-list class)
+                      :key #'sod-class-nickname :test #'equal)))
 
   ;; Check that the CHAIN-TO class is actually a proper superclass.  (This
   ;; eliminates hairy things like a class being its own link.)

diff --git a/src/utilities.lisp b/src/utilities.lisp
index 10e95c7..b02fdf4 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -679,6 +679,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.