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.

1 files changed, 84 insertions, 13 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);