From e45a106df3272c787444bc6f7b8920016b7fc677 Mon Sep 17 00:00:00 2001 Message-Id: From: Mark Wooding Date: Sun, 26 Mar 2017 10:01:28 +0100 Subject: [PATCH] src/class-finalize-*.lisp: Improve finalization error reporting. Organization: Straylight/Edgeware From: Mark Wooding Change the finalization protocol: now, `finalize-sod-class' and its helpers (notably `check-sod-class') can signal continuable errors and still have the overall finalization report failure. Actually make use of the return value in the two callers: `parse-class-body' and `bootstrap-classes'. --- doc/SYMBOLS | 2 + doc/meta.tex | 15 +++++++- src/builtin.lisp | 3 +- src/class-finalize-impl.lisp | 72 +++++++++++++++++++++++++---------- src/class-finalize-proto.lisp | 50 +++++++++++++++++++++++- src/module-parse.lisp | 3 +- 6 files changed, 118 insertions(+), 27 deletions(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index ab66f25..3b73a99 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -203,6 +203,8 @@ class-finalize-proto.lisp check-sod-class generic compute-chains generic compute-cpl generic + finalization-error macro + finalization-failed function finalize-sod-class generic guess-metaclass generic diff --git a/doc/meta.tex b/doc/meta.tex index 2523642..726e28b 100644 --- a/doc/meta.tex +++ b/doc/meta.tex @@ -308,6 +308,16 @@ %%%-------------------------------------------------------------------------- \section{Class finalization protocol} \label{sec:meta.finalization} +\begin{describe}{mac} + {finalization-error (@ @^*) \\ \ind + @^* \\ + @
^* \- + \nlret @^*} +\end{describe} + +\begin{describe}{fun}{finalization-failed} +\end{describe} + \begin{describe*} {\dhead{gf}{sod-class-precedence-list @ @> @} \dhead{gf}{sod-class-type @ @> @} @@ -332,10 +342,11 @@ \begin{describe}{gf}{check-sod-class @} \end{describe} -\begin{describe}{gf}{finalize-sod-class @} +\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)} + \begin{describe}{ar-meth}{finalize-sod-class (@ sod-class) + @> @} \end{describe} \end{describe} diff --git a/src/builtin.lisp b/src/builtin.lisp index c49f263..4d5b5cd 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -539,7 +539,8 @@ (defun bootstrap-classes (module) ;; Done. (dolist (class classes) - (finalize-sod-class class) + (unless (finalize-sod-class class) + (error "Failed to finalize built-in class")) (add-to-module module class)))) (export '*builtin-module*) diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index d5dd60d..320534b 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -306,12 +306,13 @@ (defmethod guess-metaclass ((class sod-class)) ;; 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. @@ -429,10 +430,29 @@ (defmethod finalize-sod-class :around ((class sod-class)) ;; 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 @@ -457,13 +477,20 @@ (default-slot (class 'metaclass) (guess-metaclass class)) ;; 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) @@ -475,10 +502,13 @@ (default-slot (class 'metaclass) (guess-metaclass class)) (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) diff --git a/src/class-finalize-proto.lisp b/src/class-finalize-proto.lisp index 80d0c12..2f589b8 100644 --- a/src/class-finalize-proto.lisp +++ b/src/class-finalize-proto.lisp @@ -25,6 +25,46 @@ (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. @@ -108,8 +148,14 @@ (defgeneric finalize-sod-class (class) * 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 -------------------------------------------------- diff --git a/src/module-parse.lisp b/src/module-parse.lisp index bccc37b..83828e6 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -398,7 +398,8 @@ (defun parse-class-body (scanner pset name supers) (nil (parse-raw-class-item sub-pset))) (check-unused-properties sub-pset)))) (nil (error () #\}))) - (finalize-sod-class class) + (unless (finalize-sod-class class) + (setf duff t)) (unless duff (add-to-module *module* class)))))))) -- [mdw]