;; metaclasses resolved yet. If we find this, then throw `bootstrapping'
;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
;; across the bows of anyone else who calls us).
- (select-minimal-class-property (sod-class-direct-superclasses class)
- (lambda (super)
- (if (slot-boundp super 'metaclass)
- (slot-value super 'metaclass)
- (throw 'bootstrapping nil)))
- #'sod-subclass-p class "metaclass"))
+ (finalization-error (:bad-metaclass)
+ (select-minimal-class-property (sod-class-direct-superclasses class)
+ (lambda (super)
+ (if (slot-boundp super 'metaclass)
+ (slot-value super 'metaclass)
+ (throw 'bootstrapping nil)))
+ #'sod-subclass-p class "metaclass")))
;;;--------------------------------------------------------------------------
;;; Sanity checking.
;; If this fails, leave the class marked as a loss.
(setf (slot-value class 'state) :broken)
- ;; Invoke the finalization method proper.
- (call-next-method)
- (setf (slot-value class 'state) :finalized)
- t)
+ ;; Invoke the finalization method proper. If it signals any
+ ;; continuable errors, take note of them so that we can report failure
+ ;; properly.
+ ;;
+ ;; Catch: we get called recursively to clean up superclasses and
+ ;; metaclasses, but there should only be one such handler, so don't
+ ;; add another. (In turn, this means that other methods mustn't
+ ;; actually trap their significant errors.)
+ (let ((have-handler-p (boundp '*finalization-errors*))
+ (*finalization-errors* nil)
+ (*finalization-error-token* nil))
+ (catch '%finalization-failed
+ (if have-handler-p (call-next-method)
+ (handler-bind ((error (lambda (cond)
+ (declare (ignore cond))
+ (pushnew *finalization-error-token*
+ *finalization-errors*
+ :test #'equal)
+ :decline)))
+ (call-next-method)))
+ (when *finalization-errors* (finalization-failed))
+ (setf (slot-value class 'state) :finalized)
+ t)))
;; If the class is broken, we're not going to be able to fix it now.
(:broken
;; 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)))
+ ;; This is enough to tie the knot at the top of the class graph. If we
+ ;; can't manage this then we're doomed.
+ (flet ((try-finalizing (what other-class)
+ (unless (finalize-sod-class other-class)
+ (cerror* "Class `~A' has broken ~A `~A'" class what other-class)
+ (info-with-location other-class
+ "Class `~A' defined here" other-class)
+ (finalization-failed))))
+ (let ((supers (sod-class-direct-superclasses class))
+ (meta (sod-class-metaclass class)))
+ (dolist (super supers)
+ (try-finalizing "direct superclass" super))
+ (unless (or (null supers) (eq class meta))
+ (try-finalizing "metaclass" meta))))
;; Stash the class's type.
(setf (slot-value class '%type)
(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))))
+ ;; If the CPL hasn't been done yet, compute it. If we can't manage this
+ ;; then there's no hope at all.
+ (unless (slot-boundp class 'class-precedence-list)
+ (restart-case
+ (setf (slot-value class 'class-precedence-list) (compute-cpl class))
+ (continue () :report "Continue"
+ (finalization-failed))))
;; Check that the class is fairly sane.
(check-sod-class class)
(cl:in-package #:sod)
+;;;--------------------------------------------------------------------------
+;;; Finalization error handling.
+
+;; These variables are internal to the implementation.
+(defvar-unbound *finalization-errors*
+ "A list of tokens for errors reported about the class being finalized.
+
+ During finalization, this is bound to a list of tokens corresponding to
+ the problems which have been reported so far via `finalization-error'.")
+(defvar-unbound *finalization-error-token*
+ "The token to store in `*finalization-errors*' in the event of an error.")
+
+(export 'finalization-error)
+(defmacro finalization-error ((token &rest args) &body body)
+ "Check for a kind of finalization error denoted by TOKEN and the ARGS.
+
+ The TOKEN and ARGS are convered into an error token as follows. If no
+ ARGS are given, then the TOKEN itself is evaluated and used directly;
+ otherwise, the token is a list whose first element is the result of
+ evaluating TOKEN, and the remaining elements are the results of evaluating
+ the ARGS. Error tokens are compared with `equal'.
+
+ If a finalization error denoted by this token has already been reported,
+ then do nothing: the BODY is not evaluated, and the result is nil.
+ Special exception: a nil token denotes a `generic' error which can be
+ repeated indefintely.
+
+ If the BODY signals an error (and doesn't handle it), then the error token
+ is added to a list of reported errors. That way, future calls to
+ `finalization-error' with an equal error token won't cause the user to be
+ inundated with duplicate reports."
+ `(let ((*finalization-error-token* ,(if (null args) token
+ `(list ,token ,@args))))
+ ,@body))
+
+(export 'finalization-failed)
+(defun finalization-failed ()
+ "Give up on finalizing the current class."
+ (throw '%finalization-failed nil))
+
;;;--------------------------------------------------------------------------
;;; Protocol definition.
* The layout chains are computed.
+ Returns a generalized boolean: non-nil if the class has been successfully
+ finalized -- either just now, or if it was finalized already and nothing
+ needed to be done -- or nil if finalization failed -- either just now, or
+ because the class had previously been marked as broken following a failed
+ finalization attempt.
+
User methods can assume that the class in question has not yet been
- finalized. Errors during finalization can be reported in the usual
- way."))
+ finalized. Errors during finalization can be reported in the usual way.
+ See also `finalization-error' and `finalization-failed' above."))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / commitdiff