From 2c0aab07cc749aacc29c485f85537e0f0a3c9536 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Fri, 6 Jul 2018 23:55:33 +0100 Subject: [PATCH] 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. --- doc/SYMBOLS | 4 ++++ doc/meta.tex | 10 ++++++++++ src/class-finalize-impl.lisp | 35 ++++++++++++++++++++++++++++++++++- src/class-finalize-proto.lisp | 14 ++++++++++++++ 4 files changed, 62 insertions(+), 1 deletion(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 9af73e1..4f13521 100644 --- 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 --- a/doc/meta.tex +++ b/doc/meta.tex @@ -343,6 +343,16 @@ \begin{describe}{gf}{compute-chains @ @> @} \end{describe} +\begin{describe}{gf}{check-class-initializer @ @} + \begin{describe}{meth} + {check-class-initializer (@ effective-slot) (@ sod-class)} + \end{describe} + \begin{describe}{meth} + {check-class-initializer (@ sod-class-effective-slot) + (@ sod-class)} + \end{describe} +\end{describe} + \begin{describe}{gf}{check-sod-class @} \end{describe} 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 @@ ;;;-------------------------------------------------------------------------- ;;; 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 --- 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 -- 2.11.0