--- Begin Message ---
|
Subject: |
30.0.50; Handler-bind and ert-test-error-debug |
|
Date: |
Sat, 16 Dec 2023 19:37:14 -0500 |
Package: Emacs
Version: 30.0.50
`condition-case` has served us well for the usual error handling needs
of common code, but it does not let us capture information about
the dynamic context where the error takes place, such as
capturing the value of dynamically scoped vars or the backtrace.
For that reason, `signal_or_quit` has slowly grown as new needs have
come up to run various kinds of debugger-like operations in
special cases.
The attached patch adds the new special form `handler-bind` which
provides a functionality similar to `condition-case` except that
the handler is run *before* unwinding the stack.
The patch includes a change to `ert.el` to make use of it to capture the
backtrace of errors instead of messing with `debugger` and
`debug-on-error`, which is fiddly and comes with various problems (such
as the fact that it impacts `condition-case-unless-debug`).
It's not completely finished but I'm bumping into a question.
`ert-tests.el` includes the following test:
(ert-deftest ert-test-error-debug ()
(let ((test (make-ert-test :body (lambda () (error "Error message")))))
(condition-case condition
(progn
(let ((ert-debug-on-error t))
(ert-run-test test))
(cl-assert nil))
((error)
(cl-assert (equal condition '(error "Error message")) t)))))
Until now, this test passes just like that, i.e. without entering
the debugger. With the new code, this test does enter the debugger.
Can anyone give me a hand figuring out why/how the debugger is not entered
with the current code? AFAICT when running the inner `ert-run-test`,
we get to `ert--run-test-internal` which sets `debugger` to a function
that calls `ert--run-test-debugger` and `debug-on-error` to t, yet when
it calls `(error "Error message")` this debugger-function is not called
(or at least `ert--run-test-debugger` is not called), which I can't explain.
Stefan
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 84b50777684..f73abee1587 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -278,13 +278,12 @@ ert--signal-should-execution
(when ert--should-execution-observer
(funcall ert--should-execution-observer form-description)))
-;; See Bug#24402 for why this exists
+;; See Bug#24402 for why this existed. Now we keep it simply
+;; for the sake of old `.elc' files compiled with an old `ert.el'.
(defun ert--should-signal-hook (error-symbol data)
- "Stupid hack to stop `condition-case' from catching ert signals.
-It should only be stopped when ran from inside `ert--run-test-internal'."
- (when (and (not (symbolp debugger)) ; only run on anonymous debugger
- (memq error-symbol '(ert-test-failed ert-test-skipped)))
- (funcall debugger 'error (cons error-symbol data))))
+ (declare (obsolete nil "30.1"))
+ (let ((signal-hook-function nil))
+ (signal error-symbol data)))
(defun ert--special-operator-p (thing)
"Return non-nil if THING is a symbol naming a special operator."
@@ -324,8 +323,7 @@ ert--expand-should-1
(default-value (gensym "ert-form-evaluation-aborted-")))
`(let* ((,fn (function ,fn-name))
(,args (condition-case err
- (let ((signal-hook-function
#'ert--should-signal-hook))
- (list ,@arg-forms))
+ (list ,@arg-forms)
(error (progn (setq ,fn #'signal)
(list (car err)
(cdr err)))))))
@@ -728,78 +726,65 @@ ert--test-execution-info
;; value and test execution should be terminated. Should not
;; return.
(exit-continuation (cl-assert nil))
- ;; The binding of `debugger' outside of the execution of the test.
- next-debugger
;; The binding of `ert-debug-on-error' that is in effect for the
;; execution of the current test. We store it to avoid being
;; affected by any new bindings the test itself may establish. (I
;; don't remember whether this feature is important.)
ert-debug-on-error)
-(defun ert--run-test-debugger (info args)
- "During a test run, `debugger' is bound to a closure that calls this
function.
+(defun ert--run-test-debugger (info condition)
+ "Error handler used during the test run.
This function records failures and errors and either terminates
the test silently or calls the interactive debugger, as
appropriate.
-INFO is the ert--test-execution-info corresponding to this test
-run. ARGS are the arguments to `debugger'."
- (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args)
- args
- (cl-ecase first-debugger-arg
- ((lambda debug t exit nil)
- (apply (ert--test-execution-info-next-debugger info) args))
- (error
- (let* ((condition (car more-debugger-args))
- (type (cl-case (car condition)
- ((quit) 'quit)
- ((ert-test-skipped) 'skipped)
- (otherwise 'failed)))
- ;; We store the backtrace in the result object for
- ;; `ert-results-pop-to-backtrace-for-test-at-point'.
- ;; This means we have to limit `print-level' and
- ;; `print-length' when printing result objects. That
- ;; might not be worth while when we can also use
- ;; `ert-results-rerun-test-at-point-debugging-errors',
- ;; (i.e., when running interactively) but having the
- ;; backtrace ready for printing is important for batch
- ;; use.
- ;;
- ;; Grab the frames above the debugger.
- (backtrace (cdr (backtrace-get-frames debugger)))
- (infos (reverse ert--infos)))
- (setf (ert--test-execution-info-result info)
- (cl-ecase type
- (quit
- (make-ert-test-quit :condition condition
- :backtrace backtrace
- :infos infos))
- (skipped
- (make-ert-test-skipped :condition condition
- :backtrace backtrace
- :infos infos))
- (failed
- (make-ert-test-failed :condition condition
- :backtrace backtrace
- :infos infos))))
- ;; Work around Emacs's heuristic (in eval.c) for detecting
- ;; errors in the debugger.
- (cl-incf num-nonmacro-input-events)
- ;; FIXME: We should probably implement more fine-grained
- ;; control a la non-t `debug-on-error' here.
- (cond
- ((ert--test-execution-info-ert-debug-on-error info)
- (apply (ert--test-execution-info-next-debugger info) args))
- (t))
- (funcall (ert--test-execution-info-exit-continuation info)))))))
+INFO is the `ert--test-execution-info' corresponding to this test run.
+ERR is the error object."
+ (let* ((type (cl-case (car condition)
+ ((quit) 'quit)
+ ((ert-test-skipped) 'skipped)
+ (otherwise 'failed)))
+ ;; We store the backtrace in the result object for
+ ;; `ert-results-pop-to-backtrace-for-test-at-point'.
+ ;; This means we have to limit `print-level' and
+ ;; `print-length' when printing result objects. That
+ ;; might not be worth while when we can also use
+ ;; `ert-results-rerun-test-at-point-debugging-errors',
+ ;; (i.e., when running interactively) but having the
+ ;; backtrace ready for printing is important for batch
+ ;; use.
+ ;;
+ ;; Grab the frames above ourselves.
+ (backtrace (cdr (backtrace-get-frames 'ert--run-test-debugger)))
+ (infos (reverse ert--infos)))
+ (setf (ert--test-execution-info-result info)
+ (cl-ecase type
+ (quit
+ (make-ert-test-quit :condition condition
+ :backtrace backtrace
+ :infos infos))
+ (skipped
+ (make-ert-test-skipped :condition condition
+ :backtrace backtrace
+ :infos infos))
+ (failed
+ (make-ert-test-failed :condition condition
+ :backtrace backtrace
+ :infos infos))))
+ ;; FIXME: We should probably implement more fine-grained
+ ;; control a la non-t `debug-on-error' here.
+ (cond
+ ((ert--test-execution-info-ert-debug-on-error info)
+ (apply debugger 'error condition))
+ (t))
+ (funcall (ert--test-execution-info-exit-continuation info))))
(defun ert--run-test-internal (test-execution-info)
"Low-level function to run a test according to TEST-EXECUTION-INFO.
This mainly sets up debugger-related bindings."
- (setf (ert--test-execution-info-next-debugger test-execution-info) debugger
- (ert--test-execution-info-ert-debug-on-error test-execution-info)
+ (setf (ert--test-execution-info-ert-debug-on-error test-execution-info)
ert-debug-on-error)
(catch 'ert--pass
;; For now, each test gets its own temp buffer and its own
@@ -807,26 +792,14 @@ ert--run-test-internal
;; too expensive, we can remove it.
(with-temp-buffer
(save-window-excursion
- ;; FIXME: Use `signal-hook-function' instead of `debugger' to
- ;; handle ert errors. Once that's done, remove
- ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for
- ;; details.
- (let ((lexical-binding t)
- (debugger (lambda (&rest args)
- (ert--run-test-debugger test-execution-info
- args)))
- (debug-on-error t)
- ;; Don't infloop if the error being called is erroring
- ;; out, and we have `debug-on-error' bound to nil inside
- ;; the test.
- (backtrace-on-error-noninteractive nil)
- (debug-on-quit t)
- ;; FIXME: Do we need to store the old binding of this
- ;; and consider it in `ert--run-test-debugger'?
- (debug-ignored-errors nil)
+ (let ((lexical-binding t) ;;FIXME: Why?
(ert--infos '()))
- (funcall (ert-test-body (ert--test-execution-info-test
- test-execution-info))))))
+ (handler-bind (((error quit)
+ (lambda (err)
+ (ert--run-test-debugger test-execution-info
+ err))))
+ (funcall (ert-test-body (ert--test-execution-info-test
+ test-execution-info)))))))
(ert-pass))
(setf (ert--test-execution-info-result test-execution-info)
(make-ert-test-passed))
@@ -1553,7 +1526,9 @@ ert-run-tests-batch-and-exit
(or noninteractive
(user-error "This function is only for use in batch mode"))
(let ((eln-dir (and (featurep 'native-compile)
- (make-temp-file "test-nativecomp-cache-" t))))
+ (make-temp-file "test-nativecomp-cache-" t)))
+ ;; Don't ever wait for user input.
+ (inhibit-interaction t))
(when eln-dir
(startup-redirect-eln-cache eln-dir))
;; Better crash loudly than attempting to recover from undefined
diff --git a/lisp/subr.el b/lisp/subr.el
index 7b52f4f68f9..7cc5d9ac79b 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -7496,6 +7496,36 @@ match-buffers
(push buf bufs)))
bufs))
+(defmacro handler-bind (handlers &rest body)
+ "Setup error HANDLERS around execution of BODY.
+HANDLERS is a list of (CONDITIONS HANDLER) where
+CONDITIONS should be a list of condition names (symbols) or
+a single condition name and HANDLER is a form whose evaluation
+returns a function.
+When an error is signaled during execution of BODY, if that
+error matches CONDITIONS, then the associated HANDLER
+function is called with the error as argument.
+HANDLERs can either transfer the control via a non-local exit,
+or return normally. If they return normally the search for an
+error handler continues from where it left off."
+ ;; FIXME: Completion support as in `condition-case'?
+ (declare (indent 1) (debug ((&rest (sexp form)) body)))
+ (let ((args '())
+ (bindings '()))
+ (dolist (cond+handler (reverse handlers))
+ (let ((handler (car (cdr cond+handler)))
+ (conds (car cond+handler))
+ (handlersym (gensym "handler")))
+ (push (list handlersym handler) bindings)
+ (if (not (listp conds))
+ (progn
+ (push handlersym args)
+ (push `',conds args))
+ (dolist (cond conds)
+ (push handlersym args)
+ (push `',cond args)))))
+ `(let ,bindings (handler-bind-1 (lambda () ,@body) ,@args))))
+
(defmacro with-memoization (place &rest code)
"Return the value of CODE and stash it in PLACE.
If PLACE's value is non-nil, then don't bother evaluating CODE
diff --git a/src/eval.c b/src/eval.c
index 12e811ce264..075fbf01238 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1355,6 +1355,42 @@ or (:success BODY...), where the BODY is made of Lisp
expressions.
return internal_lisp_condition_case (var, bodyform, handlers);
}
+DEFUN ("handler-bind-1", Fhandler_bind_1, Shandler_bind_1, 1, MANY, 0,
+ doc: /* Setup error handlers around execution of BODYFUN.
+BODYFUN be a function and it is called with no arguments.
+CONDITION should be a condition name (symbol).
+When an error is signaled during executon of BODYFUN, if that
+error matches CONDITION, then the associated HANDLER is
+called with the error as argument.
+HANDLER should either transfer the control via a non-local exit,
+or return normally. If it returns normally, it should return a new
+error object or nil, and the search for an error handler continues
+from where it left off, using the new error object returned by
+HANDLER (or the old error object if it returned nil).
+
+(fn BODYFUN [CONDITION HANDLER]...) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ eassert (nargs >= 1);
+ Lisp_Object bodyfun = args[0];
+ Lisp_Object map = Qnil;
+ ptrdiff_t i = 2;
+ while (i < nargs)
+ {
+ Lisp_Object condition = args[i - 1], handler = args[i];
+ map = Fcons (Fcons (condition, handler), map);
+ i += 2;
+ }
+ /* FIXME: Fsignal handles multiple conditions&handlers */
+ struct handler *current_handlerlist = handlerlist;
+ push_handler (Fnreverse (map), HANDLER);
+ eassert (handlerlist->next == current_handlerlist);
+ Lisp_Object ret = call0 (bodyfun);
+ eassert (handlerlist->next == current_handlerlist);
+ handlerlist = handlerlist->next;
+ return ret;
+}
+
/* Like Fcondition_case, but the args are separate
rather than passed in a list. Used by Fbyte_code. */
@@ -1731,6 +1767,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object
data, bool keyboard_quit)
= (NILP (error_symbol) ? Fcar (data) : error_symbol);
Lisp_Object clause = Qnil;
struct handler *h;
+ int skip;
if (gc_in_progress || waiting_for_input)
emacs_abort ();
@@ -1772,16 +1809,60 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object
data, bool keyboard_quit)
Vsignaling_function = backtrace_function (pdl);
}
- for (h = handlerlist; h; h = h->next)
+ for (skip = 0, h = handlerlist; h; skip++, h = h->next)
{
- if (h->type == CATCHER_ALL)
+ switch (h->type)
{
+ case CATCHER_ALL:
clause = Qt;
break;
- }
- if (h->type != CONDITION_CASE)
- continue;
- clause = find_handler_clause (h->tag_or_ch, conditions);
+ case CATCHER:
+ continue;
+ case CONDITION_CASE:
+ clause = find_handler_clause (h->tag_or_ch, conditions);
+ break;
+ case HANDLER:
+ {
+ Lisp_Object handlers = h->tag_or_ch;
+ for (; CONSP (handlers); handlers = XCDR (handlers))
+ {
+ Lisp_Object handler = XCAR (handlers);
+ if (CONSP (handler)
+ && !NILP (Fmemq (XCAR (handler), conditions)))
+ {
+ struct handler *current_handlerlist = handlerlist;
+ Lisp_Object error_data
+ = (NILP (error_symbol)
+ ? data : Fcons (error_symbol, data));
+ /* FIXME: This inhibits deeper catchers,
+ which isn't right! */
+ push_handler (make_fixnum (skip), SKIP_CONDITIONS);
+ eassert (handlerlist->next == current_handlerlist);
+ Lisp_Object retval = call1 (XCDR (handler), error_data);
+ /* Pop the SKIP_CONDITIONS. No need to use unwind_protect
+ since any non-local exit will set 'handlerlist'. */
+ eassert (handlerlist->next == current_handlerlist);
+ handlerlist = current_handlerlist;
+ if (CONSP (retval))
+ {
+ error_symbol = XCAR (retval);
+ data = XCDR (retval);
+ conditions = Fget (error_symbol, Qerror_conditions);
+ }
+ }
+ }
+ continue;
+ }
+ case SKIP_CONDITIONS:
+ {
+ int toskip = XFIXNUM (h->tag_or_ch);
+ while (toskip-- >= 0)
+ h = h->next;
+ continue;
+ }
+ default:
+ abort ();
+ }
if (!NILP (clause))
break;
}
@@ -1798,7 +1879,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object
data, bool keyboard_quit)
|| (CONSP (clause) && !NILP (Fmemq (Qdebug, clause)))
/* Special handler that means "print a message and run debugger
if requested". */
- || EQ (h->tag_or_ch, Qerror)))
+ || EQ (clause, Qerror)))
{
debugger_called
= maybe_call_debugger (conditions, error_symbol, data);
@@ -1813,7 +1894,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object
data, bool keyboard_quit)
to not interfere with ERT or other packages that install custom
debuggers. */
if (!debugger_called && !NILP (error_symbol)
- && (NILP (clause) || EQ (h->tag_or_ch, Qerror))
+ && (NILP (clause) || EQ (clause, Qerror))
&& noninteractive && backtrace_on_error_noninteractive
&& NILP (Vinhibit_debugger)
&& !NILP (Ffboundp (Qdebug_early)))
@@ -2052,13 +2133,10 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object
conditions)
register Lisp_Object h;
/* t is used by handlers for all conditions, set up by C code. */
- if (EQ (handlers, Qt))
- return Qt;
-
/* error is used similarly, but means print an error message
and run the debugger if that is enabled. */
- if (EQ (handlers, Qerror))
- return Qt;
+ if (!CONSP (handlers))
+ return handlers;
for (h = handlers; CONSP (h); h = XCDR (h))
{
@@ -4449,6 +4527,7 @@ syms_of_eval (void)
defsubr (&Sthrow);
defsubr (&Sunwind_protect);
defsubr (&Scondition_case);
+ defsubr (&Shandler_bind_1);
DEFSYM (QCsuccess, ":success");
defsubr (&Ssignal);
defsubr (&Scommandp);
diff --git a/src/lisp.h b/src/lisp.h
index df6cf1df544..33892eb4a68 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3618,7 +3618,8 @@ record_in_backtrace (Lisp_Object function, Lisp_Object
*args, ptrdiff_t nargs)
Members are volatile if their values need to survive _longjmp when
a 'struct handler' is a local variable. */
-enum handlertype { CATCHER, CONDITION_CASE, CATCHER_ALL };
+enum handlertype { CATCHER, CONDITION_CASE, CATCHER_ALL,
+ HANDLER, SKIP_CONDITIONS };
enum nonlocal_exit
{
--- End Message ---