unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
* bug#67862: 30.0.50; Handler-bind and ert-test-error-debug
@ 2023-12-17  0:37 Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
  2023-12-17  6:53 ` Gerd Möllmann
  2024-02-01 22:27 ` J.P.
  0 siblings, 2 replies; 13+ messages in thread
From: Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors @ 2023-12-17  0:37 UTC (permalink / raw)
  To: 67862; +Cc: Christian Ohler

[-- Attachment #1: Type: text/plain, Size: 1957 bytes --]

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

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: handler-bind.patch --]
[-- Type: text/x-diff, Size: 17896 bytes --]

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
 {

^ permalink raw reply related	[flat|nested] 13+ messages in thread
end of thread, other threads:[~2024-02-02 23:44 UTC | newest]

Thread overview: 13+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2023-12-17  0:37 bug#67862: 30.0.50; Handler-bind and ert-test-error-debug Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2023-12-17  6:53 ` Gerd Möllmann
2023-12-17 15:08   ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2023-12-26 16:25   ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2023-12-26 18:00     ` Gerd Möllmann
2023-12-31 19:43       ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-01-01  5:56         ` Gerd Möllmann
2024-01-01 12:15           ` Eli Zaretskii
2024-01-01 16:43             ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-02-01 22:27 ` J.P.
2024-02-02  2:46   ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors
2024-02-02 23:28     ` J.P.
2024-02-02 23:44       ` Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).