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

User-defined class slots must have initializers, or we get very sad
during output.  Builtin slots mustn't have initializers, or (in
practice) they'll be ignored in favour of the builtin magic.

Introduce a new function `check-class-initializer', as part of the class
finalization sanity-check protocol, which verifies that class slots are
initialized -- or not -- as required.

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 9af73e1..4f13521 100644 (file)
--- a/doc/SYMBOLS
+++ b/doc/SYMBOLS
@@ -201,6 +201,7 @@ class-finalize-impl.lisp
   report-class-list-merge-error                 function
 
 class-finalize-proto.lisp
+  check-class-initializer                       generic
   check-sod-class                               generic
   compute-chains                                generic
   compute-cpl                                   generic
@@ -829,6 +830,9 @@ chain-offset-target-head
 check-aggregating-message-type
   t t t
   aggregating-message (eql :progn) c-function-type
+check-class-initializer
+  effective-slot sod-class
+  sod-class-effective-slot sod-class
 check-message-type
   aggregating-message t
   sod-message c-function-type

diff --git a/doc/meta.tex b/doc/meta.tex
index 44d8afd..81efab9 100644 (file)
--- a/doc/meta.tex
+++ b/doc/meta.tex
@@ -343,6 +343,16 @@
 \begin{describe}{gf}{compute-chains @<class> @> @<list>}
 \end{describe}
 
+\begin{describe}{gf}{check-class-initializer @<slot> @<class>}
+  \begin{describe}{meth}
+      {check-class-initializer (@<slot> effective-slot) (@<class> sod-class)}
+  \end{describe}
+  \begin{describe}{meth}
+      {check-class-initializer (@<slot> sod-class-effective-slot)
+                               (@<class> sod-class)}
+  \end{describe}
+\end{describe}
+
 \begin{describe}{gf}{check-sod-class @<class>}
 \end{describe}
 

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.

diff --git a/src/class-finalize-proto.lisp b/src/class-finalize-proto.lisp
index edd1bad..7a64ae3 100644 (file)
--- a/src/class-finalize-proto.lisp
+++ b/src/class-finalize-proto.lisp
@@ -92,6 +92,20 @@
    If the chains are ill-formed (i.e., not distinct) then an error is
    signalled."))
 
+(export 'check-class-initializer)
+(defgeneric check-class-initializer (slot class)
+  (:documentation
+   "Check that SLOT has an appropriate initializer.
+
+   Signal an appropriate continuable error, possibly protected by
+   `finalization-error'.
+
+   The initializer might come either from the SLOT's defining class (which it
+   already knows), or from the prospective instance CLASS, of which the
+   defining class will be (a superclass of) the metaclass.  Or, if the slot
+   is magical, then the initial value might come from somewhere else and it
+   might be forbidden for a programmer to set it explicitly."))
+
 (export 'check-sod-class)
 (defgeneric check-sod-class (class)
   (:documentation