scratch/handler-bind 6a57b9151b1 06/10: Move batch backtrace code to `top_level_2`

[Stefan Monnier]

branch: scratch/handler-bind
commit 6a57b9151b149a445daecc211d8f58010e605768
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    Move batch backtrace code to `top_level_2`
    
    Move ad-hoc code meant to ease debugging of bootstrap (and batch mode)
    to `top_level_2` so it doesn't pollute `signal_or_quit`.
    
    * src/lisp.h (pop_handler, push_handler_bind): Declare.
    * src/keyboard.c (top_level_2): Setup an error handler to call
    `debug-early` when noninteractive.
    * src/eval.c (pop_handler): Not static any more.
    (signal_or_quit): Remove special case for noninteractive use.
    (push_handler_bind): New function, extracted from `Fhandler_bind_1`.
    (Fhandler_bind_1): Use it.
    (syms_of_eval): Declare `Qdebug_early__handler`.
    * lisp/emacs-lisp/debug-early.el (debug-early-backtrace): Weed out
    frames below `debug-early`.
    (debug-early--handler): New function.
---
 lisp/emacs-lisp/debug-early.el |  4 ++++
 src/eval.c                     | 38 ++++++++++++++------------------------
 src/keyboard.c                 | 12 +++++++++++-
 src/lisp.h                     |  2 ++
 4 files changed, 31 insertions(+), 25 deletions(-)

diff --git a/lisp/emacs-lisp/debug-early.el b/lisp/emacs-lisp/debug-early.el
index e393daee879..2e56d5ab321 100644
--- a/lisp/emacs-lisp/debug-early.el
+++ b/lisp/emacs-lisp/debug-early.el
@@ -94,4 +94,8 @@ available before `debug' was usable.)"
   (prin1 (cdr (car (cdr args))))       ; The error data.
   (debug-early-backtrace)))
 
+(defalias 'debug-early--handler         ;Called from C.
+  #'(lambda (err)
+      (if backtrace-on-error-noninteractive (debug-early 'error err))))
+
 ;;; debug-early.el ends here.
diff --git a/src/eval.c b/src/eval.c
index 063414deb0f..b2b110da15b 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -317,6 +317,7 @@ call_debugger (Lisp_Object arg)
   /* Interrupting redisplay and resuming it later is not safe under
      all circumstances.  So, when the debugger returns, abort the
      interrupted redisplay by going back to the top-level.  */
+  /* FIXME: Move this to the redisplay code?  */
   if (debug_while_redisplaying
       && !EQ (Vdebugger, Qdebug_early))
     Ftop_level ();
@@ -1198,7 +1199,7 @@ usage: (catch TAG BODY...)  */)
 
 #define clobbered_eassert(E) verify (sizeof (E) != 0)
 
-static void
+void
 pop_handler (void)
 {
   handlerlist = handlerlist->next;
@@ -1367,6 +1368,16 @@ usage: (condition-case VAR BODYFORM &rest HANDLERS)  */)
   return internal_lisp_condition_case (var, bodyform, handlers);
 }
 
+void
+push_handler_bind (Lisp_Object conditions, Lisp_Object handler, int skip)
+{
+  if (!CONSP (conditions))
+    conditions = Fcons (conditions, Qnil);
+  struct handler *c = push_handler (conditions, HANDLER_BIND);
+  c->val = handler;
+  c->bytecode_dest = skip;
+}
+
 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.
@@ -1392,11 +1403,7 @@ usage: (handler-bind BODYFUN [CONDITIONS HANDLER]...)  
*/)
       Lisp_Object conditions = args[i], handler = args[i + 1];
       if (NILP (conditions))
         continue;
-      else if (!CONSP (conditions))
-        conditions = Fcons (conditions, Qnil);
-      struct handler *c = push_handler (conditions, HANDLER_BIND);
-      c->val = handler;
-      c->bytecode_dest = count++;
+      push_handler_bind (conditions, handler, count++);
     }
   Lisp_Object ret = call0 (bodyfun);
   for (; count > 0; count--)
@@ -1885,24 +1892,6 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object 
data, bool keyboard_quit)
        return Qnil;
     }
 
-  /* If we're in batch mode, print a backtrace unconditionally to help
-     with debugging.  Make sure to use `debug-early' unconditionally
-     to not interfere with ERT or other packages that install custom
-     debuggers.  */
-  /* FIXME: This could be turned into a `handler-bind` at toplevel?  */
-  if (!debugger_called && !NILP (error_symbol)
-      && (NILP (clause) || EQ (clause, Qerror))
-      && noninteractive && backtrace_on_error_noninteractive
-      && NILP (Vinhibit_debugger)
-      && !NILP (Ffboundp (Qdebug_early)))
-    {
-      max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 100);
-      specpdl_ref count = SPECPDL_INDEX ();
-      specbind (Qdebugger, Qdebug_early);
-      call_debugger (list2 (Qerror, Fcons (error_symbol, data)));
-      unbind_to (count, Qnil);
-    }
-
   /* If an error is signaled during a Lisp hook in redisplay, write a
      backtrace into the buffer *Redisplay-trace*.  */
   /* FIXME: Turn this into a `handler-bind` installed during redisplay?  */
@@ -4392,6 +4381,7 @@ before making `inhibit-quit' nil.  */);
   DEFSYM (QCdocumentation, ":documentation");
   DEFSYM (Qdebug, "debug");
   DEFSYM (Qdebug_early, "debug-early");
+  DEFSYM (Qdebug_early__handler, "debug-early--handler");
 
   DEFVAR_LISP ("inhibit-debugger", Vinhibit_debugger,
               doc: /* Non-nil means never enter the debugger.
diff --git a/src/keyboard.c b/src/keyboard.c
index 39abe07e5dc..3e44a13820d 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -1163,7 +1163,17 @@ command_loop_2 (Lisp_Object handlers)
 static Lisp_Object
 top_level_2 (void)
 {
-  return Feval (Vtop_level, Qnil);
+  /* If we're in batch mode, print a backtrace unconditionally when
+     encountering an error, to help with debugging.  */
+  bool setup_handler = noninteractive;
+  if (setup_handler)
+    push_handler_bind (list1 (Qerror), Qdebug_early__handler, 0);
+
+  Lisp_Object res = Feval (Vtop_level, Qnil);
+
+  if (setup_handler)
+    pop_handler ();
+  return res;
 }
 
 static Lisp_Object
diff --git a/src/lisp.h b/src/lisp.h
index 84d7853a4f1..db6c3e32be7 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4570,6 +4570,8 @@ extern Lisp_Object internal_condition_case_n
 extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, 
Lisp_Object (*) (enum nonlocal_exit, Lisp_Object));
 extern struct handler *push_handler (Lisp_Object, enum handlertype)
   ATTRIBUTE_RETURNS_NONNULL;
+extern void pop_handler (void);
+extern void push_handler_bind (Lisp_Object, Lisp_Object, int);
 extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
 extern void specbind (Lisp_Object, Lisp_Object);
 extern void record_unwind_protect (void (*) (Lisp_Object), Lisp_Object);