X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/b045196ca0fcb1d72d2d6b1c4eabcc76df13e034..74ca1bf50dae2ae7dfa61352d77a5edba9cc3db6:/src/class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index b92b604..10d2b2f 100644
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -341,6 +341,26 @@ (defmethod compute-chains ((class sod-class))
 ;;;--------------------------------------------------------------------------
 ;;; 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,20 @@ (defmethod check-sod-class ((class sod-class))
 	    (info-with-location super
 				"Direct superclass `~A' defined here ~
 				 has metaclass `~A'"
-				super supermeta)))))))
+				super supermeta))))))
+
+  ;; 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.