master 5ba75e183c6 01/14: New special form `handler-bind`

[Stefan Monnier]

branch: master
commit 5ba75e183c60aff50949587c21066e876dabfbda
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                     |  7 ++++
 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, 227 insertions(+), 20 deletions(-)

diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index acf9be5c3ff..6cc25dcdaee 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 6239af3e138..db3b838c380 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1395,6 +1395,13 @@ This is like 'require', but it checks whether the 
argument 'feature'
 is already loaded, in which case it either signals an error or
 forcibly reloads the file that defines the feature.
 
++++
+** 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.
+See the Info node "(elisp) Handling Errors".
+
 +++
 ** 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 1bb9c2fdc2e..ca207ff548d 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 d2b8ea17f74..0519e56e057 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 object as argument.
+HANDLERs can either transfer the control via a non-local exit,
+or return normally.  If a handler returns 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 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
 {
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index e4b18ec7849..9ac117859dd 100644
--- a/test/src/eval-tests.el
+++ b/test/src/eval-tests.el
@@ -303,4 +303,41 @@ expressions works for identifiers starting with period."
       (should (eq 'bar (default-value 'eval-tests/buffer-local-var)))
       (should (eq 'bar eval-tests/buffer-local-var)))))
 
+(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