[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] feature/byte-unwind-protect a6b4b9b 1/2: Make CATCHER_ALL
From: |
Tom Tromey |
Subject: |
[Emacs-diffs] feature/byte-unwind-protect a6b4b9b 1/2: Make CATCHER_ALL work for signal as well as throw |
Date: |
Tue, 23 Jan 2018 00:12:32 -0500 (EST) |
branch: feature/byte-unwind-protect
commit a6b4b9b4af5405b62cbd59f5ce23ca0fe0027ac7
Author: Tom Tromey <address@hidden>
Commit: Tom Tromey <address@hidden>
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.
---
src/emacs-module.c | 29 ++++++++++-------------------
src/eval.c | 42 ++++++++++++++----------------------------
src/lisp.h | 9 ++++++---
3 files changed, 30 insertions(+), 50 deletions(-)
diff --git a/src/emacs-module.c b/src/emacs-module.c
index 385c308..18b9b88 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 3c2b300..05b8206 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 616aea0..f84d9bf 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.