From 64cbfb65118395be4d6628a2ba9d5b2bd95663e0 Mon Sep 17 00:00:00 2001 From: Mark Wooding 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 @ @ \&key :identity :test} +\end{describe} + +\begin{describe}{fun} {frob-identifier @ \&key :swap-case :swap-hyphen @> @} \end{describe} -\begin{describe}{fun}{whitespace-char-p @ @> @} +\begin{describe}{fun} + {whitespace-char-p @ @> @} \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