scratch/handler-bind 23479891db8 01/12: New special form `handler-bind`

[Stefan Monnier]

branch: scratch/handler-bind
commit 23479891db8632af736090d892db621106b41999
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`,
    modulo the differences about how error objects and conditions are
    represented.
    
    * 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.
    
    * lisp/emacs-lisp/lisp-mode.el (lisp-font-lock-keywords):
    Move 'handler-bind' from CL-only to generic Lisp.
    (handler-bind): Remove indentation setting, it now lives in the macro
    definition.
---
 doc/lispref/control.texi     | 38 +++++++++++++++++
 etc/NEWS                     |  6 +++
 lisp/emacs-lisp/lisp-mode.el |  5 +--
 lisp/subr.el                 | 22 ++++++++++
 src/eval.c                   | 97 ++++++++++++++++++++++++++++++++++++++------
 src/lisp.h                   | 41 +++++++++++++++++--
 test/src/eval-tests.el       | 37 +++++++++++++++++
 7 files changed, 226 insertions(+), 20 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 f82564946b7..905dccddf39 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1355,6 +1355,12 @@ 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
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index b1fc65b09ac..22d69e255af 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -343,7 +343,7 @@ This will generate compile-time constants from BINDINGS."
      (lisp-vdefs '("defvar"))
      (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1"
                 "prog2" "lambda" "unwind-protect" "condition-case"
-                "when" "unless" "with-output-to-string"
+                "when" "unless" "with-output-to-string" "handler-bind"
                 "ignore-errors" "dotimes" "dolist" "declare"))
      (lisp-errs '("warn" "error" "signal"))
      ;; Elisp constructs.  Now they are update dynamically
@@ -376,7 +376,7 @@ This will generate compile-time constants from BINDINGS."
      (cl-kw '("block" "break" "case" "ccase" "compiler-let" "ctypecase"
               "declaim" "destructuring-bind" "do" "do*"
               "ecase" "etypecase" "eval-when" "flet" "flet*"
-              "go" "handler-case" "handler-bind" "in-package" ;; "inline"
+              "go" "handler-case" "in-package" ;; "inline"
               "labels" "letf" "locally" "loop"
               "macrolet" "multiple-value-bind" "multiple-value-prog1"
               "proclaim" "prog" "prog*" "progv"
@@ -1346,7 +1346,6 @@ Lisp function does not specify a special indentation."
 (put 'catch 'lisp-indent-function 1)
 (put 'condition-case 'lisp-indent-function 2)
 (put 'handler-case 'lisp-indent-function 1) ;CL
-(put 'handler-bind 'lisp-indent-function 1) ;CL
 (put 'unwind-protect 'lisp-indent-function 1)
 (put 'with-output-to-temp-buffer 'lisp-indent-function 1)
 (put 'closure 'lisp-indent-function 2)
diff --git a/lisp/subr.el b/lisp/subr.el
index 93428c4a518..600b4d27f18 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -7497,6 +7497,28 @@ 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 '()))
+    (dolist (cond+handler handlers)
+      (let ((handler (car (cdr cond+handler)))
+            (conds (car cond+handler)))
+        (push `',(ensure-list conds) args)
+        (push handler args)))
+    `(handler-bind-1 (lambda () ,@body) ,@(nreverse 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 e13bf2103e1..063414deb0f 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1198,6 +1198,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.  */
@@ -1361,6 +1367,43 @@ 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.
+CONDITIONS should be a list of condition names (symbols).
+When an error is signaled during executon of BODYFUN, if that
+error matches one of CONDITIONS, 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 [CONDITIONS HANDLER]...)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  eassert (nargs >= 1);
+  Lisp_Object bodyfun = args[0];
+  int count = 0;
+  if (nargs % 2 == 0)
+    error ("Trailing CONDITIONS withount HANDLER in `handler-bind`");
+  for (ptrdiff_t i = nargs - 2; i > 0; i -= 2)
+    {
+      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++;
+    }
+  Lisp_Object ret = call0 (bodyfun);
+  for (; count > 0; count--)
+    pop_handler ();
+  return ret;
+}
+
 /* Like Fcondition_case, but the args are separate
    rather than passed in a list.  Used by Fbyte_code.  */
 
@@ -1737,6 +1780,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 ();
@@ -1759,6 +1803,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);
     }
 
@@ -1778,16 +1823,42 @@ 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_BIND:
+         {
+           if (!NILP (find_handler_clause (h->tag_or_ch, conditions)))
+             {
+               Lisp_Object error_data
+                 = (NILP (error_symbol)
+                    ? data : Fcons (error_symbol, data));
+               push_handler (make_fixnum (skip + h->bytecode_dest),
+                             SKIP_CONDITIONS);
+               call1 (h->val, error_data);
+               pop_handler ();
+             }
+           continue;
+         }
+       case SKIP_CONDITIONS:
+         {
+           int toskip = XFIXNUM (h->tag_or_ch);
+           while (toskip-- >= 0)
+             h = h->next;
+           continue;
+         }
+       default:
+         abort ();
+       }
       if (!NILP (clause))
        break;
     }
@@ -1804,7 +1875,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);
@@ -1818,8 +1889,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)))
@@ -1833,6 +1905,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)
@@ -2058,13 +2131,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))
     {
@@ -4494,6 +4564,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 ed1b007d4c5..84d7853a4f1 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3543,7 +3543,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'
@@ -3564,9 +3565,41 @@ 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.
+
+   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,                      /* Entry for 'catch'.
+                                   'tag_or_ch' holds the catch's tag.
+                                   'val' holds the retval during longjmp.  */
+  CONDITION_CASE,               /* Entry for 'condition-case'.
+                                   'tag_or_ch' holds the list of conditions.
+                                   'val' holds the retval during longjmp.  */
+  CATCHER_ALL,                  /* Wildcard which catches all 'throw's.
+                                   'tag_or_ch' is unused.
+                                   'val' holds the retval during longjmp.  */
+  HANDLER_BIND,                 /* Entry for 'handler-bind'.
+                                   'tag_or_ch' holds the list of conditions.
+                                   'val' holds the handler function.
+                                   The rest of the handler is unused,
+                                   except for 'bytecode_dest' that holds
+                                   the number of preceding HANDLER_BIND
+                                   entries which belong to the same
+                                   'handler-bind' (and hence need to
+                                   be muted together).  */
+  SKIP_CONDITIONS               /* Mask out the N preceding entries.
+                                   Used while running the handler of
+                                   a HANDLER_BIND to hides the condition
+                                   handlers underneath (and including)
+                                   the 'handler-bind'.
+                                   'tag_or_ch' holds that number, the rest
+                                   is unused.  */
+};
 
 enum nonlocal_exit
 {
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index 4589763b2f5..f288b985579 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