[Emacs-diffs] master 23a82cb: Refactoring: have CATCHER_ALL also catch signals.

[Philipp Stephani]

branch: master
commit 23a82cba12380b0905670c34395dc460a4bc9984
Author: Philipp Stephani <address@hidden>
Commit: Philipp Stephani <address@hidden>

    Refactoring: have CATCHER_ALL also catch signals.
    
    In all cases where we use a CATCHER_ALL handler we also want to catch
    signals.  Therefore have 'signal' respect CATCHER_ALL.  Adapt internal
    interfaces so that handlers can distinguish among the two types of
    nonlocal exits in CATCHER_ALL handlers.
    
    * src/lisp.h (enum nonlocal_exit): New enum.
    (struct handler): Add member 'nonlocal_exit' to hold the type of
    nonlocal exit during stack unwinding.
    
    * src/eval.c (signal_or_quit): Also respect CATCHER_ALL handlers.
    (unwind_to_catch): Store nonlocal exit type in catch structure.
    (Fthrow, signal_or_quit): Adapt callers.
    (internal_catch_all): Install only one handler.  Give handler a
    nonlocal exit type argument.
    (internal_catch_all_1): Remove, no longer needed.
    
    * src/emacs-module.c (MODULE_SETJMP): Install only one handler.
    (module_handle_nonlocal_exit): New function to handle all nonlocal
    exits.
    (MODULE_SETJMP_1): Pass nonlocal exit type to handler function.
    (module_handle_signal, module_handle_throw): Remove, no longer needed.
    
    * src/json.c (json_handle_nonlocal_exit): New helper function.
    (json_insert_callback): Adapt to change in 'internal_catch_all'.
---
 src/emacs-module.c | 37 ++++++++++++++++++-------------------
 src/eval.c         | 49 +++++++++++++++++--------------------------------
 src/json.c         | 15 ++++++++++++++-
 src/lisp.h         | 18 +++++++++++++++---
 4 files changed, 64 insertions(+), 55 deletions(-)

diff --git a/src/emacs-module.c b/src/emacs-module.c
index fd033e8..393a435 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -201,8 +201,8 @@ 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_nonlocal_exit (emacs_env *, enum nonlocal_exit,
+                                         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 *,
@@ -231,11 +231,8 @@ static bool module_assertions = false;
    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_nonlocal_exit, retval)
 
 #define MODULE_SETJMP(handlertype, handlerfunc, retval)                        
       \
   MODULE_SETJMP_1 (handlertype, handlerfunc, retval,                          \
@@ -271,7 +268,7 @@ static bool module_assertions = false;
     = c0;                                                              \
   if (sys_setjmp (c->jmp))                                             \
     {                                                                  \
-      (handlerfunc) (env, c->val);                                     \
+      (handlerfunc) (env, c->nonlocal_exit, c->val);                    \
       return retval;                                                   \
     }                                                                  \
   do { } while (false)
@@ -1183,20 +1180,22 @@ 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' and `throw'.  DATA is a pair
+   (ERROR-SYMBOL . ERROR-DATA) or (TAG . VALUE), which gets stored in
+   the environment.  Set the pending non-local exit flag.  */
 static void
-module_handle_signal (emacs_env *env, Lisp_Object err)
+module_handle_nonlocal_exit (emacs_env *env, enum nonlocal_exit type,
+                             Lisp_Object data)
 {
-  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));
+  switch (type)
+    {
+    case NONLOCAL_EXIT_SIGNAL:
+      module_non_local_exit_signal_1 (env, XCAR (data), XCDR (data));
+      break;
+    case NONLOCAL_EXIT_THROW:
+      module_non_local_exit_throw_1 (env, XCAR (data), XCDR (data));
+      break;
+    }
 }
 
 
diff --git a/src/eval.c b/src/eval.c
index c2e996a..23fd0ef 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1134,13 +1134,15 @@ internal_catch (Lisp_Object tag,
    This is used for correct unwinding in Fthrow and Fsignal.  */
 
 static AVOID
-unwind_to_catch (struct handler *catch, Lisp_Object value)
+unwind_to_catch (struct handler *catch, enum nonlocal_exit type,
+                 Lisp_Object value)
 {
   bool last_time;
 
   eassert (catch->next);
 
   /* Save the value in the tag.  */
+  catch->nonlocal_exit = type;
   catch->val = value;
 
   /* Restore certain special C variables.  */
@@ -1177,9 +1179,9 @@ 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));
-       if (c->type == CATCHER && EQ (c->tag_or_ch, tag))
-         unwind_to_catch (c, value);
+          unwind_to_catch (c, NONLOCAL_EXIT_THROW, Fcons (tag, value));
+        if (c->type == CATCHER && EQ (c->tag_or_ch, tag))
+         unwind_to_catch (c, NONLOCAL_EXIT_THROW, value);
       }
   xsignal2 (Qno_catch, tag, value);
 }
@@ -1427,44 +1429,21 @@ 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.  */
 
 Lisp_Object
 internal_catch_all (Lisp_Object (*function) (void *), void *argument,
-                    Lisp_Object (*handler) (Lisp_Object))
+                    Lisp_Object (*handler) (enum nonlocal_exit, 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;
@@ -1472,9 +1451,10 @@ internal_catch_all (Lisp_Object (*function) (void *), 
void *argument,
   else
     {
       eassert (handlerlist == c);
+      enum nonlocal_exit type = c->nonlocal_exit;
       Lisp_Object val = c->val;
       handlerlist = c->next;
-      return handler (val);
+      return handler (type, val);
     }
 }
 
@@ -1645,6 +1625,11 @@ 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)
+        {
+          clause = Qt;
+          break;
+        }
       if (h->type != CONDITION_CASE)
        continue;
       clause = find_handler_clause (h->tag_or_ch, conditions);
@@ -1678,7 +1663,7 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object 
data, bool keyboard_quit)
       Lisp_Object unwind_data
        = (NILP (error_symbol) ? data : Fcons (error_symbol, data));
 
-      unwind_to_catch (h, unwind_data);
+      unwind_to_catch (h, NONLOCAL_EXIT_SIGNAL, unwind_data);
     }
   else
     {
diff --git a/src/json.c b/src/json.c
index 5917212..014ac3e 100644
--- a/src/json.c
+++ b/src/json.c
@@ -665,6 +665,18 @@ json_insert (void *data)
   return Qnil;
 }
 
+static Lisp_Object
+json_handle_nonlocal_exit (enum nonlocal_exit type, Lisp_Object data)
+{
+  switch (type)
+    {
+    case NONLOCAL_EXIT_SIGNAL:
+      return data;
+    case NONLOCAL_EXIT_THROW:
+      return Fcons (Qno_catch, data);
+    }
+}
+
 struct json_insert_data
 {
   /* This tracks how many bytes were inserted by the callback since
@@ -687,7 +699,8 @@ json_insert_callback (const char *buffer, size_t size, void 
*data)
   struct json_insert_data *d = data;
   struct json_buffer_and_size buffer_and_size
     = {.buffer = buffer, .size = size, .inserted_bytes = d->inserted_bytes};
-  d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity);
+  d->error = internal_catch_all (json_insert, &buffer_and_size,
+                                 json_handle_nonlocal_exit);
   d->inserted_bytes = buffer_and_size.inserted_bytes;
   return NILP (d->error) ? 0 : -1;
 }
diff --git a/src/lisp.h b/src/lisp.h
index 0da2037..2aa767b 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3262,8 +3262,10 @@ SPECPDL_INDEX (void)
    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).
+   be treated as a handler for all invocations of `signal' and `throw';
+   in this case `val' will be set to (ERROR-SYMBOL . DATA) or (TAG . VAL),
+   respectively.  During stack unwinding, `nonlocal_exit' is set to
+   specify the type of nonlocal exit that caused the stack unwinding.
 
    All the other members are concerned with restoring the interpreter
    state.
@@ -3273,11 +3275,21 @@ SPECPDL_INDEX (void)
 
 enum handlertype { CATCHER, CONDITION_CASE, CATCHER_ALL };
 
+enum nonlocal_exit
+{
+  NONLOCAL_EXIT_SIGNAL,
+  NONLOCAL_EXIT_THROW,
+};
+
 struct handler
 {
   enum handlertype type;
   Lisp_Object tag_or_ch;
+
+  /* The next two are set by unwind_to_catch.  */
+  enum nonlocal_exit nonlocal_exit;
   Lisp_Object val;
+
   struct handler *next;
   struct handler *nextfree;
 
@@ -4129,7 +4141,7 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object 
(*) (Lisp_Object, Lisp
 extern Lisp_Object internal_condition_case_n
     (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
      Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
-extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, 
Lisp_Object (*) (Lisp_Object));
+extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, 
Lisp_Object (*) (enum nonlocal_exit, Lisp_Object));
 extern struct handler *push_handler (Lisp_Object, enum handlertype);
 extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype);
 extern void specbind (Lisp_Object, Lisp_Object);