#include "commands.h"
#include "keyboard.h"
#include "dispextern.h"
+#include "guile.h"
+
+static void unbind_once (void *ignore);
/* Chain of condition and catch handlers currently in effect. */
return pdl->let.where;
}
-static Lisp_Object
-specpdl_arg (union specbinding *pdl)
-{
- eassert (pdl->kind == SPECPDL_UNWIND);
- return pdl->unwind.arg;
-}
-
Lisp_Object
backtrace_function (union specbinding *pdl)
{
return pdl;
}
+struct handler *
+make_catch_handler (Lisp_Object tag)
+{
+ struct handler *c = xmalloc (sizeof (*c));
+ c->type = CATCHER;
+ c->tag_or_ch = tag;
+ c->val = Qnil;
+ c->var = Qnil;
+ c->body = Qnil;
+ c->next = handlerlist;
+ c->lisp_eval_depth = lisp_eval_depth;
+ c->poll_suppress_count = poll_suppress_count;
+ c->interrupt_input_blocked = interrupt_input_blocked;
+ c->ptag = make_prompt_tag ();
+ return c;
+}
+
+struct handler *
+make_condition_handler (Lisp_Object tag)
+{
+ struct handler *c = xmalloc (sizeof (*c));
+ c->type = CONDITION_CASE;
+ c->tag_or_ch = tag;
+ c->val = Qnil;
+ c->var = Qnil;
+ c->body = Qnil;
+ c->next = handlerlist;
+ c->lisp_eval_depth = lisp_eval_depth;
+ c->poll_suppress_count = poll_suppress_count;
+ c->interrupt_input_blocked = interrupt_input_blocked;
+ c->ptag = make_prompt_tag ();
+ return c;
+}
void
init_eval_once (void)
Vrun_hooks = Qnil;
}
-static struct handler handlerlist_sentinel;
+static struct handler *handlerlist_sentinel;
void
init_eval (void)
{
specpdl_ptr = specpdl;
- { /* Put a dummy catcher at top-level so that handlerlist is never NULL.
- This is important since handlerlist->nextfree holds the freelist
- which would otherwise leak every time we unwind back to top-level. */
- struct handler *c;
- handlerlist = handlerlist_sentinel.nextfree = &handlerlist_sentinel;
- PUSH_HANDLER (c, Qunbound, CATCHER);
- eassert (c == &handlerlist_sentinel);
- handlerlist_sentinel.nextfree = NULL;
- handlerlist_sentinel.next = NULL;
- }
+ handlerlist_sentinel = make_catch_handler (Qunbound);
+ handlerlist = handlerlist_sentinel;
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
Lisp_Object val;
EMACS_INT old_depth = max_lisp_eval_depth;
/* Do not allow max_specpdl_size less than actual depth (Bug#16603). */
- EMACS_INT old_max = max (max_specpdl_size, count);
+ EMACS_INT old_max = max_specpdl_size;
if (lisp_eval_depth + 40 > max_lisp_eval_depth)
max_lisp_eval_depth = lisp_eval_depth + 40;
- /* While debugging Bug#16603, previous value of 100 was found
- too small to avoid specpdl overflow in the debugger itself. */
- if (max_specpdl_size - 200 < count)
- max_specpdl_size = count + 200;
-
- if (old_max == count)
- {
- /* We can enter the debugger due to specpdl overflow (Bug#16603). */
- specpdl_ptr--;
- grow_specpdl ();
- }
-
/* Restore limits after leaving the debugger. */
record_unwind_protect (restore_stack_limits,
Fcons (make_number (old_max),
#define clobbered_eassert(E) ((void) 0)
+static void
+set_handlerlist (void *data)
+{
+ handlerlist = data;
+}
+
+static void
+restore_handler (void *data)
+{
+ struct handler *c = data;
+ set_poll_suppress_count (c->poll_suppress_count);
+ unblock_input_to (c->interrupt_input_blocked);
+ immediate_quit = 0;
+}
+
+struct icc_thunk_env
+{
+ enum { ICC_0, ICC_1, ICC_2, ICC_3, ICC_N } type;
+ union
+ {
+ Lisp_Object (*fun0) (void);
+ Lisp_Object (*fun1) (Lisp_Object);
+ Lisp_Object (*fun2) (Lisp_Object, Lisp_Object);
+ Lisp_Object (*fun3) (Lisp_Object, Lisp_Object, Lisp_Object);
+ Lisp_Object (*funn) (ptrdiff_t, Lisp_Object *);
+ };
+ union
+ {
+ struct
+ {
+ Lisp_Object arg1;
+ Lisp_Object arg2;
+ Lisp_Object arg3;
+ };
+ struct
+ {
+ ptrdiff_t nargs;
+ Lisp_Object *args;
+ };
+ };
+ struct handler *c;
+};
+
+static Lisp_Object
+icc_thunk (void *data)
+{
+ Lisp_Object tem;
+ struct icc_thunk_env *e = data;
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (restore_handler, e->c, 0);
+ scm_dynwind_unwind_handler (set_handlerlist,
+ handlerlist,
+ SCM_F_WIND_EXPLICITLY);
+ handlerlist = e->c;
+ switch (e->type)
+ {
+ case ICC_0:
+ tem = e->fun0 ();
+ break;
+ case ICC_1:
+ tem = e->fun1 (e->arg1);
+ break;
+ case ICC_2:
+ tem = e->fun2 (e->arg1, e->arg2);
+ break;
+ case ICC_3:
+ tem = e->fun3 (e->arg1, e->arg2, e->arg3);
+ break;
+ case ICC_N:
+ tem = e->funn (e->nargs, e->args);
+ break;
+ default:
+ emacs_abort ();
+ }
+ scm_dynwind_end ();
+ return tem;
+}
+
+static Lisp_Object
+icc_handler (void *data, Lisp_Object k, Lisp_Object v)
+{
+ Lisp_Object (*f) (Lisp_Object) = data;
+ return f (v);
+}
+
+struct icc_handler_n_env
+{
+ Lisp_Object (*fun) (Lisp_Object, ptrdiff_t, Lisp_Object *);
+ ptrdiff_t nargs;
+ Lisp_Object *args;
+};
+
+static Lisp_Object
+icc_handler_n (void *data, Lisp_Object k, Lisp_Object v)
+{
+ struct icc_handler_n_env *e = data;
+ return e->fun (v, e->nargs, e->args);
+}
+
+static Lisp_Object
+icc_lisp_handler (void *data, Lisp_Object k, Lisp_Object val)
+{
+ Lisp_Object tem;
+ struct handler *h = data;
+ Lisp_Object var = h->var;
+ scm_dynwind_begin (0);
+ if (!NILP (var))
+ {
+ if (!NILP (Vinternal_interpreter_environment))
+ specbind (Qinternal_interpreter_environment,
+ Fcons (Fcons (var, val),
+ Vinternal_interpreter_environment));
+ else
+ specbind (var, val);
+ }
+ tem = Fprogn (h->body);
+ scm_dynwind_end ();
+ return tem;
+}
+
/* Set up a catch, then call C function FUNC on argument ARG.
FUNC should return a Lisp_Object.
This is how catches are done from within C code. */
Lisp_Object
internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
{
- /* This structure is made part of the chain `catchlist'. */
- struct handler *c;
-
- /* Fill in the components of c, and put it on the list. */
- PUSH_HANDLER (c, tag, CATCHER);
-
- /* Call FUNC. */
- if (! sys_setjmp (c->jmp))
- {
- Lisp_Object val = (*func) (arg);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
- }
- else
- { /* Throw works by a longjmp that comes right here. */
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
- }
+ struct handler *c = make_catch_handler (tag);
+ struct icc_thunk_env env = { .type = ICC_1,
+ .fun1 = func,
+ .arg1 = arg,
+ .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler, Fidentity, 2, 0));
}
/* Unwind the specbind, catch, and handler stacks back to CATCH, and
static _Noreturn void
unwind_to_catch (struct handler *catch, Lisp_Object value)
{
- bool last_time;
-
- eassert (catch->next);
-
- /* Save the value in the tag. */
- catch->val = value;
-
- /* Restore certain special C variables. */
- set_poll_suppress_count (catch->poll_suppress_count);
- unblock_input_to (catch->interrupt_input_blocked);
- immediate_quit = 0;
-
- do
- {
- /* Unwind the specpdl stack, and then restore the proper set of
- handlers. */
- unbind_to_1 (handlerlist->pdlcount, Qnil, false);
- last_time = handlerlist == catch;
- if (! last_time)
- handlerlist = handlerlist->next;
- }
- while (! last_time);
-
- eassert (handlerlist == catch);
-
- gcprolist = catch->gcpro;
-#ifdef DEBUG_GCPRO
- gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
-#endif
- lisp_eval_depth = catch->lisp_eval_depth;
-
- sys_longjmp (catch->jmp, 1);
+ abort_to_prompt (catch->ptag, scm_list_1 (value));
}
DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
return internal_lisp_condition_case (var, bodyform, handlers);
}
+static Lisp_Object
+ilcc1 (Lisp_Object var, Lisp_Object bodyform, Lisp_Object handlers)
+{
+ if (CONSP (handlers))
+ {
+ Lisp_Object clause = XCAR (handlers);
+ Lisp_Object condition = XCAR (clause);
+ Lisp_Object body = XCDR (clause);
+ if (!CONSP (condition))
+ condition = Fcons (condition, Qnil);
+ struct handler *c = make_condition_handler (condition);
+ c->var = var;
+ c->body = body;
+ struct icc_thunk_env env = { .type = ICC_3,
+ .fun3 = ilcc1,
+ .arg1 = var,
+ .arg2 = bodyform,
+ .arg3 = XCDR (handlers),
+ .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_lisp_handler, c, 2, 0));
+ }
+ else
+ {
+ return eval_sub (bodyform);
+ }
+}
+
/* Like Fcondition_case, but the args are separate
rather than passed in a list. Used by Fbyte_code. */
Lisp_Object val;
struct handler *c;
struct handler *oldhandlerlist = handlerlist;
- int clausenb = 0;
CHECK_SYMBOL (var);
for (val = handlers; CONSP (val); val = XCDR (val))
{
Lisp_Object tem = XCAR (val);
- clausenb++;
if (! (NILP (tem)
|| (CONSP (tem)
&& (SYMBOLP (XCAR (tem))
SDATA (Fprin1_to_string (tem, Qt)));
}
- { /* The first clause is the one that should be checked first, so it should
- be added to handlerlist last. So we build in `clauses' a table that
- contains `handlers' but in reverse order. */
- Lisp_Object *clauses = alloca (clausenb * sizeof (Lisp_Object *));
- Lisp_Object *volatile clauses_volatile = clauses;
- int i = clausenb;
- for (val = handlers; CONSP (val); val = XCDR (val))
- clauses[--i] = XCAR (val);
- for (i = 0; i < clausenb; i++)
- {
- Lisp_Object clause = clauses[i];
- Lisp_Object condition = XCAR (clause);
- if (!CONSP (condition))
- condition = Fcons (condition, Qnil);
- PUSH_HANDLER (c, condition, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- ptrdiff_t count = SPECPDL_INDEX ();
- Lisp_Object val = handlerlist->val;
- Lisp_Object *chosen_clause = clauses_volatile;
- for (c = handlerlist->next; c != oldhandlerlist; c = c->next)
- chosen_clause++;
- handlerlist = oldhandlerlist;
- if (!NILP (var))
- {
- if (!NILP (Vinternal_interpreter_environment))
- specbind (Qinternal_interpreter_environment,
- Fcons (Fcons (var, val),
- Vinternal_interpreter_environment));
- else
- specbind (var, val);
- }
- val = Fprogn (XCDR (*chosen_clause));
- /* Note that this just undoes the binding of var; whoever
- longjumped to us unwound the stack to c.pdlcount before
- throwing. */
- if (!NILP (var))
- unbind_to (count, Qnil);
- return val;
- }
- }
- }
-
- val = eval_sub (bodyform);
- handlerlist = oldhandlerlist;
- return val;
+ return ilcc1 (var, bodyform, Freverse (handlers));
}
/* Call the function BFUN with no arguments, catching errors within it
Lisp_Object (*hfun) (Lisp_Object))
{
Lisp_Object val;
- struct handler *c;
+ struct handler *c = make_condition_handler (handlers);
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return (*hfun) (val);
- }
-
- val = (*bfun) ();
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
+ struct icc_thunk_env env = { .type = ICC_0, .fun0 = bfun, .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler, hfun, 2, 0));
}
/* Like internal_condition_case but call BFUN with ARG as its argument. */
Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object))
{
Lisp_Object val;
- struct handler *c;
+ struct handler *c = make_condition_handler (handlers);
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return (*hfun) (val);
- }
-
- val = (*bfun) (arg);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
+ struct icc_thunk_env env = { .type = ICC_1,
+ .fun1 = bfun,
+ .arg1 = arg,
+ .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler, hfun, 2, 0));
}
/* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
Lisp_Object (*hfun) (Lisp_Object))
{
Lisp_Object val;
- struct handler *c;
-
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return (*hfun) (val);
- }
-
- val = (*bfun) (arg1, arg2);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
+ struct handler *c = make_condition_handler (handlers);
+ struct icc_thunk_env env = { .type = ICC_2,
+ .fun2 = bfun,
+ .arg1 = arg1,
+ .arg2 = arg2,
+ .c = c };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler, hfun, 2, 0));
}
/* Like internal_condition_case but call BFUN with NARGS as first,
Lisp_Object *args))
{
Lisp_Object val;
- struct handler *c;
+ struct handler *c = make_condition_handler (handlers);
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
- if (sys_setjmp (c->jmp))
- {
- Lisp_Object val = handlerlist->val;
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return (*hfun) (val, nargs, args);
- }
-
- val = (*bfun) (nargs, args);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
+ struct icc_thunk_env env = { .type = ICC_N,
+ .funn = bfun,
+ .nargs = nargs,
+ .args = args,
+ .c = c };
+ struct icc_handler_n_env henv = { .fun = hfun, .nargs = nargs, .args = args };
+ return call_with_prompt (c->ptag,
+ make_c_closure (icc_thunk, &env, 0, 0),
+ make_c_closure (icc_handler_n, &henv, 2, 0));
}
\f
}
else
{
- if (handlerlist != &handlerlist_sentinel)
+ if (handlerlist != handlerlist_sentinel)
/* FIXME: This will come right back here if there's no `top-level'
catcher. A better solution would be to abort here, and instead
add a catch-all condition handler so we never come here. */
specpdl_ptr->bt.args = args;
specpdl_ptr->bt.nargs = nargs;
grow_specpdl ();
+ scm_dynwind_unwind_handler (unbind_once, NULL, SCM_F_WIND_EXPLICITLY);
+}
+
+static void
+set_lisp_eval_depth (void *data)
+{
+ EMACS_INT n = (EMACS_INT) data;
+ lisp_eval_depth = n;
}
/* Eval a sub-expression of the current expression (i.e. in the same
maybe_gc ();
UNGCPRO;
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (set_lisp_eval_depth,
+ (void *) lisp_eval_depth,
+ SCM_F_WIND_EXPLICITLY);
+
if (++lisp_eval_depth > max_lisp_eval_depth)
{
if (max_lisp_eval_depth < 100)
xsignal1 (Qinvalid_function, original_fun);
}
- lisp_eval_depth--;
if (backtrace_debug_on_exit (specpdl_ptr - 1))
val = call_debugger (list2 (Qexit, val));
- specpdl_ptr--;
+ scm_dynwind_end ();
return val;
}
QUIT;
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (set_lisp_eval_depth,
+ (void *) lisp_eval_depth,
+ SCM_F_WIND_EXPLICITLY);
+
if (++lisp_eval_depth > max_lisp_eval_depth)
{
if (max_lisp_eval_depth < 100)
else
xsignal1 (Qinvalid_function, original_fun);
}
- lisp_eval_depth--;
if (backtrace_debug_on_exit (specpdl_ptr - 1))
val = call_debugger (list2 (Qexit, val));
- specpdl_ptr--;
+ scm_dynwind_end ();
return val;
}
\f
specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT;
grow_specpdl ();
Fset_default (symbol, value);
- return;
+ goto done;
}
}
else
}
default: emacs_abort ();
}
+
+ done:
+ scm_dynwind_unwind_handler (unbind_once, NULL, SCM_F_WIND_EXPLICITLY);
}
/* Push unwind-protect entries of various types. */
record_unwind_protect_1 (void (*function) (Lisp_Object), Lisp_Object arg,
bool wind_explicitly)
{
- specpdl_ptr->unwind.kind = SPECPDL_UNWIND;
- specpdl_ptr->unwind.func = function;
- specpdl_ptr->unwind.arg = arg;
- specpdl_ptr->unwind.wind_explicitly = wind_explicitly;
- grow_specpdl ();
+ record_unwind_protect_ptr_1 (function, arg, wind_explicitly);
}
void
record_unwind_protect_ptr_1 (void (*function) (void *), void *arg,
bool wind_explicitly)
{
- specpdl_ptr->unwind_ptr.kind = SPECPDL_UNWIND_PTR;
- specpdl_ptr->unwind_ptr.func = function;
- specpdl_ptr->unwind_ptr.arg = arg;
- specpdl_ptr->unwind_ptr.wind_explicitly = wind_explicitly;
- grow_specpdl ();
+ scm_dynwind_unwind_handler (function,
+ arg,
+ (wind_explicitly
+ ? SCM_F_WIND_EXPLICITLY
+ : 0));
}
void
record_unwind_protect_int_1 (void (*function) (int), int arg,
bool wind_explicitly)
{
- specpdl_ptr->unwind_int.kind = SPECPDL_UNWIND_INT;
- specpdl_ptr->unwind_int.func = function;
- specpdl_ptr->unwind_int.arg = arg;
- specpdl_ptr->unwind_int.wind_explicitly = wind_explicitly;
- grow_specpdl ();
+ record_unwind_protect_ptr_1 (function, arg, wind_explicitly);
}
void
record_unwind_protect_int_1 (function, arg, true);
}
+static void
+call_void (void *data)
+{
+ ((void (*) (void)) data) ();
+}
+
void
record_unwind_protect_void_1 (void (*function) (void),
bool wind_explicitly)
{
- specpdl_ptr->unwind_void.kind = SPECPDL_UNWIND_VOID;
- specpdl_ptr->unwind_void.func = function;
- specpdl_ptr->unwind_void.wind_explicitly = wind_explicitly;
- grow_specpdl ();
+ record_unwind_protect_ptr_1 (call_void, function, wind_explicitly);
}
void
record_unwind_protect_void_1 (function, true);
}
-void
-unbind_once (bool explicit)
+static void
+unbind_once (void *ignore)
{
/* Decrement specpdl_ptr before we do the work to unbind it, so
that an error in unbinding won't try to unbind the same entry
switch (specpdl_ptr->kind)
{
- case SPECPDL_UNWIND:
- if (specpdl_ptr->unwind.wind_explicitly || ! explicit)
- specpdl_ptr->unwind.func (specpdl_ptr->unwind.arg);
- break;
- case SPECPDL_UNWIND_PTR:
- if (specpdl_ptr->unwind_ptr.wind_explicitly || ! explicit)
- specpdl_ptr->unwind_ptr.func (specpdl_ptr->unwind_ptr.arg);
- break;
- case SPECPDL_UNWIND_INT:
- if (specpdl_ptr->unwind_int.wind_explicitly || ! explicit)
- specpdl_ptr->unwind_int.func (specpdl_ptr->unwind_int.arg);
- break;
- case SPECPDL_UNWIND_VOID:
- if (specpdl_ptr->unwind_void.wind_explicitly || ! explicit)
- specpdl_ptr->unwind_void.func ();
- break;
case SPECPDL_BACKTRACE:
break;
case SPECPDL_LET:
void
dynwind_begin (void)
{
- specpdl_ptr->kind = SPECPDL_FRAME;
- grow_specpdl ();
+ scm_dynwind_begin (0);
}
void
dynwind_end (void)
{
- enum specbind_tag last;
- Lisp_Object quitf = Vquit_flag;
- union specbinding *pdl = specpdl_ptr;
-
- Vquit_flag = Qnil;
-
- do
- pdl--;
- while (pdl->kind != SPECPDL_FRAME);
-
- while (specpdl_ptr != pdl)
- unbind_once (true);
-
- Vquit_flag = quitf;
-}
-
-static Lisp_Object
-unbind_to_1 (ptrdiff_t count, Lisp_Object value, bool explicit)
-{
- Lisp_Object quitf = Vquit_flag;
- struct gcpro gcpro1, gcpro2;
-
- GCPRO2 (value, quitf);
- Vquit_flag = Qnil;
-
- while (specpdl_ptr != specpdl + count)
- unbind_once (explicit);
-
- if (NILP (Vquit_flag) && !NILP (quitf))
- Vquit_flag = quitf;
-
- UNGCPRO;
- return value;
-}
-
-Lisp_Object
-unbind_to (ptrdiff_t count, Lisp_Object value)
-{
- return unbind_to_1 (count, value, true);
+ scm_dynwind_end ();
}
DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
/* */
switch (tmp->kind)
{
- /* FIXME: Ideally we'd like to "temporarily unwind" (some of) those
- unwind_protect, but the problem is that we don't know how to
- rewind them afterwards. */
- case SPECPDL_UNWIND:
- case SPECPDL_UNWIND_PTR:
- case SPECPDL_UNWIND_INT:
- case SPECPDL_UNWIND_VOID:
case SPECPDL_BACKTRACE:
break;
case SPECPDL_LET:
union specbinding *pdl = backtrace_top ();
return (backtrace_p (pdl) ? backtrace_function (pdl) : Qnil);
}
+\f
+_Noreturn SCM
+abort_to_prompt (SCM tag, SCM arglst)
+{
+ static SCM var = SCM_UNDEFINED;
+ if (SCM_UNBNDP (var))
+ var = scm_c_public_lookup ("guile", "abort-to-prompt");
+ scm_apply_1 (scm_variable_ref (var), tag, arglst);
+ emacs_abort ();
+}
+
+SCM
+call_with_prompt (SCM tag, SCM thunk, SCM handler)
+{
+ static SCM var = SCM_UNDEFINED;
+ if (SCM_UNBNDP (var))
+ var = scm_c_public_lookup ("guile", "call-with-prompt");
+
+ return scm_call_3 (scm_variable_ref (var), tag, thunk, handler);
+}
+
+SCM
+make_prompt_tag (void)
+{
+ static SCM var = SCM_UNDEFINED;
+ if (SCM_UNBNDP (var))
+ var = scm_c_public_lookup ("guile", "make-prompt-tag");
+
+ return scm_call_0 (scm_variable_ref (var));
+}
+\f
void
syms_of_eval (void)
{
#include "systime.h"
#include "atimer.h"
#include "process.h"
+#include "guile.h"
#include <errno.h>
#ifdef HAVE_PTHREAD
/* For longjmp to where kbd input is being done. */
-static sys_jmp_buf getcjmp;
+static Lisp_Object getctag;
/* True while doing kbd input. */
bool waiting_for_input;
static Lisp_Object make_lispy_focus_out (Lisp_Object);
#endif /* HAVE_WINDOW_SYSTEM */
static bool help_char_p (Lisp_Object);
-static void save_getcjmp (sys_jmp_buf *);
-static void restore_getcjmp (sys_jmp_buf *);
static Lisp_Object apply_modifiers (int, Lisp_Object);
static void clear_event (struct input_event *);
static void restore_kboard_configuration (int);
read_menu_command (void)
{
Lisp_Object keybuf[30];
- ptrdiff_t count = SPECPDL_INDEX ();
+ scm_dynwind_begin (0);
int i;
/* We don't want to echo the keystrokes while navigating the
i = read_key_sequence (keybuf, ARRAYELTS (keybuf),
Qnil, 0, 1, 1, 1);
- unbind_to (count, Qnil);
+ scm_dynwind_end ();
if (! FRAME_LIVE_P (XFRAME (selected_frame)))
Fkill_emacs (Qnil);
static Lisp_Object
read_event_from_main_queue (struct timespec *end_time,
- sys_jmp_buf *local_getcjmp,
+ Lisp_Object local_tag,
bool *used_mouse_menu)
{
Lisp_Object c = Qnil;
+ Lisp_Object save_tag = Qnil;
sys_jmp_buf *save_jump = xmalloc (sizeof *save_jump);
KBOARD *kb IF_LINT (= NULL);
return c;
/* Actually read a character, waiting if necessary. */
- save_getcjmp (save_jump);
- restore_getcjmp (local_getcjmp);
+ save_tag = getctag;
+ getctag = local_tag;
if (!end_time)
timer_start_idle ();
c = kbd_buffer_get_event (&kb, used_mouse_menu, end_time);
- restore_getcjmp (save_jump);
+ getctag = save_tag;
if (! NILP (c) && (kb != current_kboard))
{
to tty input. */
static Lisp_Object
read_decoded_event_from_main_queue (struct timespec *end_time,
- sys_jmp_buf *local_getcjmp,
+ Lisp_Object local_getcjmp,
Lisp_Object prev_event,
bool *used_mouse_menu)
{
bool *used_mouse_menu;
struct timespec *end_time;
Lisp_Object c;
- ptrdiff_t jmpcount;
- sys_jmp_buf *local_getcjmp;
- sys_jmp_buf *save_jump;
+ Lisp_Object tag;
+ Lisp_Object local_tag;
+ Lisp_Object save_tag;
Lisp_Object previous_echo_area_message;
Lisp_Object also_record;
bool reread;
static Lisp_Object read_char_1 (bool, volatile struct read_char_state *);
+static Lisp_Object
+read_char_thunk (void *data)
+{
+ return read_char_1 (false, data);
+}
+
+static Lisp_Object
+read_char_handle_quit (void *data, Lisp_Object k)
+{
+ struct read_char_state *state = data;
+ /* Handle quits while reading the keyboard. */
+ /* We must have saved the outer value of getcjmp here,
+ so restore it now. */
+ getctag = state->save_tag;
+ XSETINT (state->c, quit_char);
+ internal_last_event_frame = selected_frame;
+ Vlast_event_frame = internal_last_event_frame;
+ /* If we report the quit char as an event,
+ don't do so more than once. */
+ if (!NILP (Vinhibit_quit))
+ Vquit_flag = Qnil;
+
+ {
+ KBOARD *kb = FRAME_KBOARD (XFRAME (selected_frame));
+ if (kb != current_kboard)
+ {
+ Lisp_Object last = KVAR (kb, kbd_queue);
+ /* We shouldn't get here if we were in single-kboard mode! */
+ if (single_kboard)
+ emacs_abort ();
+ if (CONSP (last))
+ {
+ while (CONSP (XCDR (last)))
+ last = XCDR (last);
+ if (!NILP (XCDR (last)))
+ emacs_abort ();
+ }
+ if (!CONSP (last))
+ kset_kbd_queue (kb, list1 (state->c));
+ else
+ XSETCDR (last, list1 (state->c));
+ kb->kbd_queue_has_data = 1;
+ current_kboard = kb;
+ /* This is going to exit from read_char
+ so we had better get rid of this frame's stuff. */
+ UNGCPRO;
+ return make_number (-2); /* wrong_kboard_jmpbuf */
+ }
+ }
+ return read_char_1 (true, state);
+}
+
/* {{coccinelle:skip_start}} */
Lisp_Object
read_char (int commandflag, Lisp_Object map,
Lisp_Object prev_event,
bool *used_mouse_menu, struct timespec *end_time)
{
- volatile struct read_char_state *state = xmalloc (sizeof *state);
+ struct read_char_state *state = xmalloc (sizeof *state);
state->commandflag = commandflag;
state->map = map;
state->used_mouse_menu = used_mouse_menu;
state->end_time = end_time;
state->c = Qnil;
- state->local_getcjmp = xmalloc (sizeof (*state->local_getcjmp));
- state->save_jump = xmalloc (sizeof (*state->save_jump));
+ state->local_tag = Qnil;
+ state->save_tag = Qnil;
state->previous_echo_area_message = Qnil;
state->also_record = Qnil;
state->reread = false;
around any call to sit_for or kbd_buffer_get_event;
it *must not* be in effect when we call redisplay. */
- state->jmpcount = SPECPDL_INDEX ();
- if (sys_setjmp (*state->local_getcjmp))
- {
- /* Handle quits while reading the keyboard. */
- /* We must have saved the outer value of getcjmp here,
- so restore it now. */
- restore_getcjmp (state->save_jump);
- pthread_sigmask (SIG_SETMASK, &empty_mask, 0);
- unbind_to (state->jmpcount, Qnil);
- XSETINT (state->c, quit_char);
- internal_last_event_frame = selected_frame;
- Vlast_event_frame = internal_last_event_frame;
- /* If we report the quit char as an event,
- don't do so more than once. */
- if (!NILP (Vinhibit_quit))
- Vquit_flag = Qnil;
-
- {
- KBOARD *kb = FRAME_KBOARD (XFRAME (selected_frame));
- if (kb != current_kboard)
- {
- Lisp_Object last = KVAR (kb, kbd_queue);
- /* We shouldn't get here if we were in single-kboard mode! */
- if (single_kboard)
- emacs_abort ();
- if (CONSP (last))
- {
- while (CONSP (XCDR (last)))
- last = XCDR (last);
- if (!NILP (XCDR (last)))
- emacs_abort ();
- }
- if (!CONSP (last))
- kset_kbd_queue (kb, list1 (state->c));
- else
- XSETCDR (last, list1 (state->c));
- kb->kbd_queue_has_data = 1;
- current_kboard = kb;
- /* This is going to exit from read_char
- so we had better get rid of this frame's stuff. */
- UNGCPRO;
- return make_number (-2); /* wrong_kboard_jmpbuf */
- }
- }
- return read_char_1 (true, state);
- }
+ state->tag = state->local_tag = make_prompt_tag ();
- return read_char_1 (false, state);
+ return call_with_prompt (state->tag,
+ make_c_closure (read_char_thunk, state, 0, 0),
+ make_c_closure (read_char_handle_quit, state, 1, 0));
}
static Lisp_Object
#define end_time state->end_time
#define c state->c
#define jmpcount state->jmpcount
-#define local_getcjmp state->local_getcjmp
-#define save_jump state->save_jump
+#define local_getcjmp state->local_tag
+#define save_jump state->save_tag
#define previous_echo_area_message state->previous_echo_area_message
#define also_record state->also_record
#define reread state->reread
#define polling_stopped_here state->polling_stopped_here
#define orig_kboard state->orig_kboard
+#define save_getcjmp(x) (x = getctag)
+#define restore_getcjmp(x) (getctag = x)
Lisp_Object tem, save;
if (jump)
#undef reread
#undef polling_stopped_here
#undef orig_kboard
+#undef save_getcjmp
+#undef restore_getcjmp
}
/* {{coccinelle:skip_end}} */
unblock_input ();
}
}
-
-/* Copy out or in the info on where C-g should throw to.
- This is used when running Lisp code from within get_char,
- in case get_char is called recursively.
- See read_process_output. */
-
-static void
-save_getcjmp (sys_jmp_buf *temp)
-{
- memcpy (*temp, getcjmp, sizeof getcjmp);
-}
-
-static void
-restore_getcjmp (sys_jmp_buf *temp)
-{
- memcpy (getcjmp, *temp, sizeof getcjmp);
-}
\f
/* Low level keyboard/mouse input.
kbd_buffer_store_event places events in kbd_buffer, and
do_switch_frame (make_lispy_switch_frame (internal_last_event_frame),
0, 0, Qnil);
- sys_longjmp (getcjmp, 1);
+ abort_to_prompt (getctag, SCM_EOL);
}
\f
DEFUN ("set-input-interrupt-mode", Fset_input_interrupt_mode,
HCoop / bpt / emacs.git / commitdiff