X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3b92d2b13d6784a8e30babcf6def39d2ba05082f..51af043f73c683c0609d4285a1bfee7d07e08b7a:/src/class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index 6401318..2978bd4 100644
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -123,7 +123,7 @@
    direct subclass then that subclass's direct superclasses list must order
    them relative to each other."
 
-  (dolist (class so-far)
+  (dolist (class (reverse so-far))
     (dolist (candidate candidates)
       (when (member candidate (sod-class-direct-superclasses class))
 	(return-from clos-tiebreaker candidate))))
@@ -341,6 +341,26 @@
 ;;;--------------------------------------------------------------------------
 ;;; Sanity checking.
 
+(defmethod check-class-initializer ((slot effective-slot) (class sod-class))
+  (finalization-error (:missing-class-initializer)
+    (unless (find-class-initializer slot class)
+      (let ((dslot (effective-slot-direct-slot slot)))
+	(cerror* "Missing initializer for class slot `~A', ~
+		  defined by meta-superclass `~A' of `~A'"
+		 dslot (sod-slot-class dslot) class)))))
+
+(defmethod check-class-initializer
+    ((slot sod-class-effective-slot) (class sod-class))
+  ;; The programmer shouldn't set an explicit initializer here.
+  (finalization-error (:invalid-class-initializer)
+    (let ((init (find-class-initializer slot class))
+	  (dslot (effective-slot-direct-slot slot)))
+      (when init
+	(cerror* "Initializers not permitted for class slot `~A', ~
+		  defined by meta-superclass `~A' of `~A'"
+		 dslot (sod-slot-class dslot) class)
+	(info-with-location init "Offending initializer defined here")))))
+
 (defmethod check-sod-class ((class sod-class))
 
   ;; Check the names of things are valid.
@@ -494,7 +514,29 @@
 	    (info-with-location super
 				"Direct superclass `~A' defined here ~
 				 has metaclass `~A'"
-				super supermeta)))))))
+				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
+  ;; that the caller knows what they're doing.
+  (let* ((meta (sod-class-metaclass class))
+	 (ilayout (and (eq (sod-class-state meta) :finalized)
+		       (sod-class-ilayout meta))))
+    (dolist (ichain (and ilayout (ilayout-ichains ilayout)))
+      (dolist (item (cdr (ichain-body ichain)))
+	(when (typep item 'islots)
+	  (dolist (slot (islots-slots item))
+	    (check-class-initializer slot class)))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Finalization.