src/class-finalize-{proto,impl}.lisp: Check class slot initializers.

[sod] / src / class-finalize-impl.lisp

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index b92b604..10d2b2f 100644 (file)
--- a/src/class-finalize-impl.lisp
+++ b/src/class-finalize-impl.lisp
@@ -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,20 @@
            (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.