From 23a82cba12380b0905670c34395dc460a4bc9984 Mon Sep 17 00:00:00 2001 From: Philipp Stephani Date: Fri, 19 Apr 2019 01:04:55 +0200 Subject: [PATCH] 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 fd033e8044f..393a4354b88 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 c2e996a9474..23fd0efd54a 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 5917212899e..014ac3e3168 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 0da20375228..2aa767b86c2 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); -- 2.39.5