From: Tom Tromey <tom@tromey.com>
Date: Fri, 19 Jan 2018 04:40:51 +0000 (-0700)
Subject: Make CATCHER_ALL work for signal as well as throw
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=a6b4b9b4af5405b62cbd59f5ce23ca0fe0027ac7;p=emacs.git

Make CATCHER_ALL work for signal as well as throw

* src/emacs-module.c (MODULE_HANDLE_NONLOCAL_EXIT): Use
module_handle_unwind_protect.
(module_handle_signal, module_handle_throw): Remove.
(module_handle_unwind_protect): New function.
* src/eval.c (Fthrow): Add 'throw to value thrown to
CATCHER_ALL.
(internal_catch_all_1): Remove.
(internal_catch_all): Use CATCHER_ALL.
(signal_or_quit): Also unwind to CATCHER_ALL.
(syms_of_eval): Define Qthrow.
* src/lisp.h (enum handlertype): Update comment.
---

diff --git a/src/emacs-module.c b/src/emacs-module.c
index 385c3089a90..18b9b88bc86 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -125,8 +125,7 @@ static emacs_env *initialize_environment (emacs_env *,
 static void finalize_environment (emacs_env *);
 static void finalize_environment_unwind (void *);
 static void finalize_runtime_unwind (void *);
-static void module_handle_signal (emacs_env *, Lisp_Object);
-static void module_handle_throw (emacs_env *, Lisp_Object);
+static void module_handle_unwind_protect (emacs_env *, Lisp_Object);
 static void module_non_local_exit_signal_1 (emacs_env *,
 					    Lisp_Object, Lisp_Object);
 static void module_non_local_exit_throw_1 (emacs_env *,
@@ -164,11 +163,8 @@ static struct emacs_env_private global_env_private;
    or a pointer to handle non-local exits.  The function must have an
    ENV parameter.  The function will return the specified value if a
    signal or throw is caught.  */
-/* TODO: Have Fsignal check for CATCHER_ALL so we only have to install
-   one handler.  */
 #define MODULE_HANDLE_NONLOCAL_EXIT(retval)                     \
-  MODULE_SETJMP (CONDITION_CASE, module_handle_signal, retval); \
-  MODULE_SETJMP (CATCHER_ALL, module_handle_throw, retval)
+  MODULE_SETJMP (CATCHER_ALL, module_handle_unwind_protect, retval)
 
 #define MODULE_SETJMP(handlertype, handlerfunc, retval)			       \
   MODULE_SETJMP_1 (handlertype, handlerfunc, retval,			       \
@@ -1141,22 +1137,17 @@ module_reset_handlerlist (struct handler **phandlerlist)
   handlerlist = handlerlist->next;
 }
 
-/* Called on `signal'.  ERR is a pair (SYMBOL . DATA), which gets
-   stored in the environment.  Set the pending non-local exit flag.  */
+/* Called on `signal' or `throw'.  Set the pending non-local exit
+   flag.  */
 static void
-module_handle_signal (emacs_env *env, Lisp_Object err)
+module_handle_unwind_protect (emacs_env *env, Lisp_Object obj)
 {
-  module_non_local_exit_signal_1 (env, XCAR (err), XCDR (err));
-}
-
-/* Called on `throw'.  TAG_VAL is a pair (TAG . VALUE), which gets
-   stored in the environment.  Set the pending non-local exit flag.  */
-static void
-module_handle_throw (emacs_env *env, Lisp_Object tag_val)
-{
-  module_non_local_exit_throw_1 (env, XCAR (tag_val), XCDR (tag_val));
+  Lisp_Object err = XCDR (obj);
+  if (EQ (XCAR (err), Qsignal))
+    module_non_local_exit_signal_1 (env, XCAR (err), XCDR (err));
+  else
+    module_non_local_exit_throw_1 (env, XCAR (err), XCDR (err));
 }
-
 
 /* Support for assertions.  */
 void
diff --git a/src/eval.c b/src/eval.c
index 3c2b300096b..05b820669ef 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1168,7 +1168,7 @@ Both TAG and VALUE are evalled.  */
     for (c = handlerlist; c; c = c->next)
       {
 	if (c->type == CATCHER_ALL)
-          unwind_to_catch (c, Fcons (tag, value));
+          unwind_to_catch (c, Fcons (Qthrow, Fcons (tag, value)));
 	if (c->type == CATCHER && EQ (c->tag_or_ch, tag))
 	  unwind_to_catch (c, value);
       }
@@ -1416,29 +1416,6 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *),
     }
 }
 
-static Lisp_Object
-internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument)
-{
-  struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL);
-  if (c == NULL)
-    return Qcatch_all_memory_full;
-
-  if (sys_setjmp (c->jmp) == 0)
-    {
-      Lisp_Object val = function (argument);
-      eassert (handlerlist == c);
-      handlerlist = c->next;
-      return val;
-    }
-  else
-    {
-      eassert (handlerlist == c);
-      Lisp_Object val = c->val;
-      handlerlist = c->next;
-      Fsignal (Qno_catch, val);
-    }
-}
-
 /* Like a combination of internal_condition_case_1 and internal_catch.
    Catches all signals and throws.  Never exits nonlocally; returns
    Qcatch_all_memory_full if no handler could be allocated.  */
@@ -1447,13 +1424,13 @@ Lisp_Object
 internal_catch_all (Lisp_Object (*function) (void *), void *argument,
                     Lisp_Object (*handler) (Lisp_Object))
 {
-  struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE);
+  struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL);
   if (c == NULL)
     return Qcatch_all_memory_full;
 
   if (sys_setjmp (c->jmp) == 0)
     {
-      Lisp_Object val = internal_catch_all_1 (function, argument);
+      Lisp_Object val = function (argument);
       eassert (handlerlist == c);
       handlerlist = c->next;
       return val;
@@ -1463,7 +1440,7 @@ internal_catch_all (Lisp_Object (*function) (void *), void *argument,
       eassert (handlerlist == c);
       Lisp_Object val = c->val;
       handlerlist = c->next;
-      return handler (val);
+      return handler (XCDR (val));
     }
 }
 
@@ -1634,6 +1611,8 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
 
   for (h = handlerlist; h; h = h->next)
     {
+      if (h->type == CATCHER_ALL)
+	break;
       if (h->type != CONDITION_CASE)
 	continue;
       clause = find_handler_clause (h->tag_or_ch, conditions);
@@ -1644,6 +1623,8 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
   if (/* Don't run the debugger for a memory-full error.
 	 (There is no room in memory to do that!)  */
       !NILP (error_symbol)
+      /* Don't run the debugger for CATCHER_ALL.  */
+      && (h == NULL || h->type != CATCHER_ALL)
       && (!NILP (Vdebug_on_signal)
 	  /* If no handler is present now, try to run the debugger.  */
 	  || NILP (clause)
@@ -1662,11 +1643,14 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool keyboard_quit)
 	return Qnil;
     }
 
-  if (!NILP (clause))
+  if (!NILP (clause) || (h != NULL && h->type == CATCHER_ALL))
     {
       Lisp_Object unwind_data
 	= (NILP (error_symbol) ? data : Fcons (error_symbol, data));
 
+      if (!NILP (error_symbol) && h->type == CATCHER_ALL)
+	unwind_data = Fcons (Qsignal, unwind_data);
+
       unwind_to_catch (h, unwind_data);
     }
   else
@@ -4121,6 +4105,8 @@ alist of active lexical bindings.  */);
   DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full");
   Funintern (Qcatch_all_memory_full, Qnil);
 
+  DEFSYM (Qthrow, "throw");
+
   defsubr (&Sor);
   defsubr (&Sand);
   defsubr (&Sif);
diff --git a/src/lisp.h b/src/lisp.h
index 616aea07805..f84d9bf5cc5 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3221,9 +3221,12 @@ SPECPDL_INDEX (void)
    A call like (throw TAG VAL) searches for a catchtag whose `tag_or_ch'
    member is TAG, and then unbinds to it.  The `val' member is used to
    hold VAL while the stack is unwound; `val' is returned as the value
-   of the catch form.  If there is a handler of type CATCHER_ALL, it will
-   be treated as a handler for all invocations of `throw'; in this case
-   `val' will be set to (TAG . VAL).
+   of the catch form.
+
+   If there is a handler of type CATCHER_ALL, it will be treated as a
+   handler for all invocations of `throw' and `signal'.  For a throw,
+   `val' will be set to (throw TAG . VAL).  For a signal, `val' will
+   be set to (signal SYMBOL . DATA).
 
    All the other members are concerned with restoring the interpreter
    state.