src/class-finalize-{proto,impl}.lisp (finalize-sod-class): Add `:around'.

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.

diff --git a/doc/SYMBOLS b/doc/SYMBOLS
index 5e076c5378ccedefad3ba8469ddd141fd554386b..f78c310508c781f141aa58a4d70913d402e0accb 100644 (file)
--- 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 25bed345f0391f8e16b5d4a565612853b7e38841..92fac6dd8f066499591ed7dde3a292127ee80dc8 100644 (file)
--- a/doc/meta.tex
+++ b/doc/meta.tex
@@ -326,6 +326,10 @@
 \end{describe}
 
 \begin{describe}{gf}{finalize-sod-class @<class>}
+  \begin{describe}{meth}{finalize-sod-class (@<class> sod-class)}
+  \end{describe}
+  \begin{describe}{ar-meth}{finalize-sod-class (@<class> sod-class)}
+  \end{describe}
 \end{describe}
 
 \begin{describe}{fun}{clos-cpl @<class> @> @<list>}

diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp
index a51075b6d94245aafe8ca8582d849eec462659c9..32bc29b812037e8663fc19fb67b89e5177da8248 100644 (file)
--- 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 7d7a992db4fb50582ebc1d48bcb2d79780d61171..80d0c121ca184554d30d31213e5092f7995eb2d2 100644 (file)
--- 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 --------------------------------------------------