X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/2c0aab07cc749aacc29c485f85537e0f0a3c9536..d5fdd49e70b734b791eb907706f92da5775e2a8b:/src/class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 10d2b2f..895b3c9 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,60 +390,70 @@
 	       (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
+		     :test #'equal)
 
     ;; 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
+		     :test #'equal)
 
     ;; 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.)
   (let ((link (sod-class-chain-link class)))
     (unless (or (not link)
 		(member link (cdr (sod-class-precedence-list class))))
-      (cerror* "In `~A~, chain-to class `~A' is not a proper superclass"
+      (cerror* "In `~A', chain-to class `~A' is not a proper superclass"
 	       class link)))
 
   ;; Check that the initargs declare compatible types.  Duplicate entries,
@@ -516,6 +519,15 @@
 				 has metaclass `~A'"
 				super supermeta))))))
 
+  ;; Check that all of the messages we can be sent have coherent collections
+  ;; of applicable methods.  This can go wrong, for example, if we inherit
+  ;; methods with differently typed keyword arguments.
+  (finalization-error (:mismatched-applicable-methods)
+    (dolist (super (sod-class-precedence-list class))
+      (dolist (message (sod-class-messages super))
+	(let ((methods (sod-message-applicable-methods message class)))
+	  (sod-message-check-methods message class methods)))))
+
   ;; Check that an initializer is available for every slot in the class's
   ;; metaclass.  Skip this and trust the caller if the metaclass isn't
   ;; finalized yet: in that case, we must be bootstrapping, and we must hope