From 32bb097f2613b22e14feb1a9820eb21289856eb3 Mon Sep 17 00:00:00 2001 Message-Id: <32bb097f2613b22e14feb1a9820eb21289856eb3.1715524800.git.mdw@distorted.org.uk> From: Mark Wooding Date: Sun, 26 Mar 2017 10:24:37 +0100 Subject: [PATCH] src/class-finalize-{proto,impl}.lisp (finalize-sod-class): Add `:around'. Organization: Straylight/Edgeware From: Mark Wooding The `around' method handles the recursiveness and state tracking (and will accumulate further functionality later). The primary method actually does the calculation and checking needed to make a class work. --- doc/SYMBOLS | 1 + doc/meta.tex | 4 ++ src/class-finalize-impl.lisp | 106 +++++++++++++++++++--------------- src/class-finalize-proto.lisp | 6 +- 4 files changed, 70 insertions(+), 47 deletions(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 5e076c5..f78c310 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -1080,6 +1080,7 @@ finalize-module module finalize-sod-class sod-class + sod-class [:around] find-slot-initargs sod-class sod-slot find-slot-initializer diff --git a/doc/meta.tex b/doc/meta.tex index 25bed34..92fac6d 100644 --- a/doc/meta.tex +++ b/doc/meta.tex @@ -326,6 +326,10 @@ \end{describe} \begin{describe}{gf}{finalize-sod-class @} + \begin{describe}{meth}{finalize-sod-class (@ sod-class)} + \end{describe} + \begin{describe}{ar-meth}{finalize-sod-class (@ sod-class)} + \end{describe} \end{describe} \begin{describe}{fun}{clos-cpl @ @> @} diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index a51075b..32bc29b 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -421,67 +421,81 @@ (defmethod check-sod-class ((class sod-class)) ;;;-------------------------------------------------------------------------- ;;; Finalization. -(defmethod finalize-sod-class ((class sod-class)) +(defmethod finalize-sod-class :around ((class sod-class)) + "Common functionality for `finalize-sod-class'. - ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief) - ;; clone of the CPL and chain establishment code. If the interface changes - ;; then `bootstrap-classes' will need to be changed too. + * If an attempt to finalize the CLASS has been made before, then we + don't try again. Similarly, attempts to finalize a class recursively + will fail. + * A condition handler is established to keep track of whether any errors + are signalled during finalization. The CLASS is only marked as + successfully finalized if no (unhandled) errors are encountered." (with-default-error-location (class) (ecase (sod-class-state class) ((nil) - ;; If this fails, mark the class as a loss. + ;; If this fails, leave the class marked as a loss. (setf (slot-value class 'state) :broken) - ;; Set up the metaclass if it's not been set already. This is delayed - ;; to give bootstrapping a chance to set up metaclass and superclass - ;; circularities. - (default-slot (class 'metaclass) (guess-metaclass class)) - - ;; Finalize all of the superclasses. There's some special pleading - ;; here to make bootstrapping work: we don't try to finalize the - ;; metaclass if we're a root class (no direct superclasses -- because - ;; in that case the metaclass will have to be a subclass of us!), or - ;; if it's equal to us. This is enough to tie the knot at the top of - ;; the class graph. - (with-slots (name direct-superclasses metaclass) class - (dolist (super direct-superclasses) - (finalize-sod-class super)) - (unless (or (null direct-superclasses) - (eq class metaclass)) - (finalize-sod-class metaclass))) - - ;; Stash the class's type. - (setf (slot-value class '%type) - (make-class-type (sod-class-name class))) - - ;; Clobber the lists of items if they've not been set. - (dolist (slot '(slots instance-initializers class-initializers - messages methods)) - (unless (slot-boundp class slot) - (setf (slot-value class slot) nil))) - - ;; If the CPL hasn't been done yet, compute it. - (with-slots (class-precedence-list) class - (unless (slot-boundp class 'class-precedence-list) - (setf class-precedence-list (compute-cpl class)))) - - ;; Check that the class is fairly sane. - (check-sod-class class) - - ;; Determine the class's layout. - (with-slots (chain-head chain chains) class - (setf (values chain-head chain chains) (compute-chains class))) - - ;; Done. + ;; Invoke the finalization method proper. + (call-next-method) (setf (slot-value class 'state) :finalized) t) + ;; If the class is broken, we're not going to be able to fix it now. (:broken nil) + ;; If we already finalized it, there's no point doing it again. (:finalized t)))) +(defmethod finalize-sod-class ((class sod-class)) + + ;; CLONE-AND-HACK WARNING: Note that `bootstrap-classes' has a (very brief) + ;; clone of the CPL and chain establishment code. If the interface changes + ;; then `bootstrap-classes' will need to be changed too. + + ;; Set up the metaclass if it's not been set already. This is delayed + ;; to give bootstrapping a chance to set up metaclass and superclass + ;; circularities. + (default-slot (class 'metaclass) (guess-metaclass class)) + + ;; Finalize all of the superclasses. There's some special pleading here to + ;; make bootstrapping work: we don't try to finalize the metaclass if we're + ;; a root class (no direct superclasses -- because in that case the + ;; metaclass will have to be a subclass of us!), or if it's equal to us. + ;; This is enough to tie the knot at the top of the class graph. + (with-slots (name direct-superclasses metaclass) class + (dolist (super direct-superclasses) + (finalize-sod-class super)) + (unless (or (null direct-superclasses) + (eq class metaclass)) + (finalize-sod-class metaclass))) + + ;; Stash the class's type. + (setf (slot-value class '%type) + (make-class-type (sod-class-name class))) + + ;; Clobber the lists of items if they've not been set. + (dolist (slot '(slots instance-initializers class-initializers + messages methods)) + (unless (slot-boundp class slot) + (setf (slot-value class slot) nil))) + + ;; If the CPL hasn't been done yet, compute it. + (with-slots (class-precedence-list) class + (unless (slot-boundp class 'class-precedence-list) + (setf class-precedence-list (compute-cpl class)))) + + ;; Check that the class is fairly sane. + (check-sod-class class) + + ;; Determine the class's layout. + (setf (values (slot-value class 'chain-head) + (slot-value class 'chain) + (slot-value class 'chains)) + (compute-chains class))) + ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/class-finalize-proto.lisp b/src/class-finalize-proto.lisp index 7d7a992..80d0c12 100644 --- a/src/class-finalize-proto.lisp +++ b/src/class-finalize-proto.lisp @@ -106,6 +106,10 @@ (defgeneric finalize-sod-class (class) * The class is checked for compiance with the well-formedness rules. - * The layout chains are computed.")) + * The layout chains are computed. + + User methods can assume that the class in question has not yet been + finalized. Errors during finalization can be reported in the usual + way.")) ;;;----- That's all, folks -------------------------------------------------- -- [mdw]