From 64cbfb65118395be4d6628a2ba9d5b2bd95663e0 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 9 Jul 2018 12:56:28 +0100
Subject: [PATCH] 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.
---
 doc/SYMBOLS                  |  1 +
 doc/misc.tex                 |  7 +++-
 src/class-finalize-impl.lisp | 79 +++++++++++++++++++++-----------------------
 src/utilities.lisp           | 36 ++++++++++++++++++++
 4 files changed, 81 insertions(+), 42 deletions(-)

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 63e0abc..4b3c490 100644
--- 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
--- 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
--- 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
--- 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.
 
-- 
2.11.0

