2 files changed, 121 insertions, 17 deletions

diff --git a/src/eval.c b/src/eval.c
index 7f67b5a9db8..595267f7686 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 10018e4dde7..2b30326abfc 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
 {