scratch/handler-bind 034f453c176 1/7: New special form `handler-bind`

[Stefan Monnier]

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

    New special form `handler-bind`
    
    AFAIK, this provides the same semantics as Common Lisp's `handler-bind`.
    
    * lisp/subr.el (handler-bind): New macro.
    
    * src/eval.c (pop_handler): New function.
    (Fhandler_Bind_1): New function.
    (signal_or_quit): Handle new handlertypes `HANDLER` and `SKIP_CONDITIONS`.
    (find_handler_clause): Simplify.
    (syms_of_eval): Defsubr `Fhandler_bind_1`.
    
    * doc/lispref/control.texi (Handling Errors): Add `handler-bind`.
    
    * test/src/eval-tests.el (eval-tests--handler-bind): New test.
---
 doc/lispref/control.texi |  38 ++++++++++++++++++
 etc/NEWS                 |   5 +++
 lisp/subr.el             |  30 ++++++++++++++
 src/eval.c               | 102 +++++++++++++++++++++++++++++++++++++++++------
 src/lisp.h               |  23 +++++++++--
 test/src/eval-tests.el   |  37 +++++++++++++++++
 6 files changed, 218 insertions(+), 17 deletions(-)

diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index d4bd8c14ae3..4107963eed5 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -2293,6 +2293,44 @@ should be robust if one does occur.  Note that this 
macro uses
 @code{condition-case-unless-debug} rather than @code{condition-case}.
 @end defmac
 
+Occasionally, we want to catch some errors and record some information
+about the conditions in which they occurred, such as the full
+backtrace, or the current buffer.  This kinds of information is sadly
+not available in the handlers of a @code{condition-case} because the
+stack is unwound before running that handler, so the handler is run in
+the dynamic context of the @code{condition-case} rather than that of
+the place where the error was signaled.  For those circumstances, you
+can use the following form:
+
+@defmac handler-bind handlers body@dots{}
+This special form runs @var{body} and if it executes without error,
+the value it returns becomes the value of the @code{handler-bind}
+form.  In this case, the @code{handler-bind} has no effect.
+
+@var{handlers} should be a list of elements of the form
+@code{(@var{conditions} @var{handler})} where @var{conditions} is an
+error condition name to be handled, or a list of condition names, and
+@var{handler} should be a form whose evaluation should return a function.
+
+Before running @var{body}, @code{handler-bind} evaluates all the
+@var{handler} forms and installs those handlers to be active during
+the evaluation of @var{body}.  These handlers are searched together
+with those installed by @code{condition-case}.  When the innermost
+matching handler is one installed by @code{handler-bind}, the
+@var{handler} function is called with a single argument holding the
+error description.
+
+@var{handler} is called in the dynamic context where the error
+happened, without first unwinding the stack, meaning that all the
+dynamic bindings are still in effect, except that all the error
+handlers between the code that signaled the error and the
+@code{handler-bind} are temporarily suspended.  Like any normal
+function, @var{handler} can exit non-locally, typically via
+@code{throw}, or it can return normally.  If @var{handler} returns
+normally, it means the handler @emph{declined} to handle the error and
+the search for an error handler is continued where it left off.
+@end defmac
+
 @node Error Symbols
 @subsubsection Error Symbols and Condition Names
 @cindex error symbol
diff --git a/etc/NEWS b/etc/NEWS
index 90ff23b7937..8e71b0a903d 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1326,6 +1326,11 @@ values.
 
 * Lisp Changes in Emacs 30.1
 
+** New special form 'handler-bind'.
+Provides a functionality similar to `condition-case` except it runs the
+handler code without unwinding the stack, such that we can record the
+backtrace and other dynamic state at the point of the error.
+
 ** New 'pop-up-frames' action alist entry for 'display-buffer'.
 This has the same effect as the variable of the same name and takes
 precedence over the variable when present.
diff --git a/lisp/subr.el b/lisp/subr.el
index 93428c4a518..c53dd333303 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -7497,6 +7497,36 @@ predicate conditions in CONDITION."
         (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 419285eb694..e00886afbc8 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1192,6 +1192,12 @@ usage: (catch TAG BODY...)  */)
 
 #define clobbered_eassert(E) verify (sizeof (E) != 0)
 
+static void
+pop_handler (void)
+{
+  handlerlist = handlerlist->next;
+}
+
 /* Set up a catch, then call C function FUNC on argument ARG.
    FUNC should return a Lisp_Object.
    This is how catches are done from within C code.  */
@@ -1355,6 +1361,37 @@ usage: (condition-case VAR BODYFORM &rest HANDLERS)  */)
   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, the search for an error handler continues
+from where it left off.
+
+usage: (handler-bind 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;
+    }
+  push_handler (Fnreverse (map), HANDLER);
+  Lisp_Object ret = call0 (bodyfun);
+  pop_handler ();
+  return ret;
+}
+
 /* Like Fcondition_case, but the args are separate
    rather than passed in a list.  Used by Fbyte_code.  */
 
@@ -1731,6 +1768,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 ();
@@ -1753,6 +1791,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object 
data, bool keyboard_quit)
       /* Edebug takes care of restoring these variables when it exits.  */
       max_ensure_room (&max_lisp_eval_depth, lisp_eval_depth, 20);
 
+      /* FIXME: 'handler-bind' makes `signal-hook-function' obsolete?  */
       call2 (Vsignal_hook_function, error_symbol, data);
     }
 
@@ -1772,16 +1811,53 @@ 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)))
+                 {
+                   Lisp_Object error_data
+                     = (NILP (error_symbol)
+                        ? data : Fcons (error_symbol, data));
+                   push_handler (make_fixnum (skip), SKIP_CONDITIONS);
+                   Lisp_Object retval = call1 (XCDR (handler), error_data);
+                   pop_handler ();
+                   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 +1874,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);
@@ -1812,8 +1888,9 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object 
data, bool keyboard_quit)
      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 (h->tag_or_ch, Qerror))
+      && (NILP (clause) || EQ (clause, Qerror))
       && noninteractive && backtrace_on_error_noninteractive
       && NILP (Vinhibit_debugger)
       && !NILP (Ffboundp (Qdebug_early)))
@@ -1827,6 +1904,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object 
data, bool keyboard_quit)
 
   /* 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?  */
   if (!debugger_called && !NILP (error_symbol)
       && backtrace_on_redisplay_error
       && (NILP (clause) || h == redisplay_deep_handler)
@@ -2052,13 +2130,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))
     {
@@ -4461,6 +4536,7 @@ alist of active lexical bindings.  */);
   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..ee7ceb8e250 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3595,7 +3595,8 @@ record_in_backtrace (Lisp_Object function, Lisp_Object 
*args, ptrdiff_t nargs)
 }
 
 /* This structure helps implement the `catch/throw' and `condition-case/signal'
-   control structures.  A struct handler contains all the information needed to
+   control structures as well as 'handler-bind'.
+   A struct handler contains all the information needed to
    restore the state of the interpreter after a non-local jump.
 
    Handler structures are chained together in a doubly linked list; the `next'
@@ -3616,9 +3617,23 @@ record_in_backtrace (Lisp_Object function, Lisp_Object 
*args, ptrdiff_t nargs)
    state.
 
    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 };
+   a 'struct handler' is a local variable.
+
+   For the HANDLER and SKIP_CONDITIONS cases, we only make use of the
+   `tag_or_ch` field and none of the rest, because there's no longjmp
+   to jump to.
+   [ Maybe we should split the handler-list into a list of restart point
+     (for CATCHERs and CONDITION_CASEs) and a list of conditions handlers
+     (for HANDLERs and CONDITION_CASEs)?  ]
+
+   When running the HANDLER of a 'handler-bind', we need to
+   temporarily "mute" the CONDITION_CASEs and HANDLERs that are "below"
+   the current handler, but without hiding any CATCHERs.  We do that by
+   installing a SKIP_CONDITIONS which tells the search to skip the
+   N next conditions.  */
+
+enum handlertype { CATCHER, CONDITION_CASE, CATCHER_ALL,
+                   HANDLER, SKIP_CONDITIONS };
 
 enum nonlocal_exit
 {
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index 4589763b2f5..71049d927a9 100644
--- a/test/src/eval-tests.el
+++ b/test/src/eval-tests.el
@@ -282,4 +282,41 @@ expressions works for identifiers starting with period."
   (should-error (defvaralias 'eval-tests--my-c 'eval-tests--my-d)
                 :type 'cyclic-variable-indirection))
 
+(ert-deftest eval-tests--handler-bind ()
+  ;; A `handler-bind' has no effect if no error is signaled.
+  (should (equal (catch 'tag
+                   (handler-bind ((error (lambda (err) (throw 'tag 'wow))))
+                     'noerror))
+                 'noerror))
+  ;; The handler is called from within the dynamic extent where the
+  ;; error is signaled, unlike `condition-case'.
+  (should (equal (catch 'tag
+                   (handler-bind ((error (lambda (_err) (throw 'tag 'err))))
+                     (list 'inner-catch
+                           (catch 'tag
+                             (user-error "hello")))))
+                 '(inner-catch err)))
+  ;; But inner condition handlers are temporarily muted.
+  (should (equal (condition-case nil
+                     (handler-bind
+                         ((error (lambda (_err)
+                                   (signal 'wrong-type-argument nil))))
+                       (list 'result
+                             (condition-case nil
+                                 (user-error "hello")
+                               (wrong-type-argument 'inner-handler))))
+                   (wrong-type-argument 'wrong-type-argument))
+                 'wrong-type-argument))
+  ;; Handlers do not apply to the code run within the handlers.
+  (should (equal (condition-case nil
+                     (handler-bind
+                         ((error (lambda (_err)
+                                   (signal 'wrong-type-argument nil)))
+                          (wrong-type-argument
+                           (lambda (_err) (user-error "wrong-type-argument"))))
+                       (user-error "hello"))
+                   (wrong-type-argument 'wrong-type-argument)
+                   (error 'plain-error))
+                 'wrong-type-argument)))
+
 ;;; eval-tests.el ends here