Commit 23a82cba authored by Philipp Stephani's avatar Philipp Stephani

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'.
parent e712a8fe
Pipeline #1341 failed with stage
in 50 minutes and 20 seconds
......@@ -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;
}
}
......
......@@ -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
{
......
......@@ -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;
}
......
......@@ -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);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment