summaryrefslogtreecommitdiff
path: root/src/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'src/eval.c')
-rw-r--r--src/eval.c217
1 files changed, 186 insertions, 31 deletions
diff --git a/src/eval.c b/src/eval.c
index 3aff3b56d52..48104bd0f45 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -219,8 +219,17 @@ void
init_eval_once (void)
{
/* Don't forget to update docs (lispref node "Local Variables"). */
- max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */
- max_lisp_eval_depth = 800;
+ if (!NATIVE_COMP_FLAG)
+ {
+ max_specpdl_size = 1800; /* See bug#46818. */
+ max_lisp_eval_depth = 800;
+ }
+ else
+ {
+ /* Original values increased for comp.el. */
+ max_specpdl_size = 2500;
+ max_lisp_eval_depth = 1600;
+ }
Vrun_hooks = Qnil;
pdumper_do_now_and_after_load (init_eval_once_for_pdumper);
}
@@ -453,7 +462,7 @@ DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
usage: (progn BODY...) */)
(Lisp_Object body)
{
- Lisp_Object val = Qnil;
+ Lisp_Object CACHEABLE val = Qnil;
while (CONSP (body))
{
@@ -1165,21 +1174,23 @@ usage: (catch TAG BODY...) */)
FUNC should return a Lisp_Object.
This is how catches are done from within C code. */
+/* MINIBUFFER_QUIT_LEVEL is to handle quitting from nested minibuffers by
+ throwing t to tag `exit'.
+ 0 means there is no (throw 'exit t) in progress, or it wasn't from
+ a minibuffer which isn't the most nested;
+ N > 0 means the `throw' was done from the minibuffer at level N which
+ wasn't the most nested. */
+EMACS_INT minibuffer_quit_level = 0;
+
Lisp_Object
internal_catch (Lisp_Object tag,
Lisp_Object (*func) (Lisp_Object), Lisp_Object arg)
{
- /* MINIBUFFER_QUIT_LEVEL is to handle quitting from nested minibuffers by
- throwing t to tag `exit'.
- Value -1 means there is no (throw 'exit t) in progress;
- 0 means the `throw' wasn't done from an active minibuffer;
- N > 0 means the `throw' was done from the minibuffer at level N. */
- static EMACS_INT minibuffer_quit_level = -1;
/* This structure is made part of the chain `catchlist'. */
struct handler *c = push_handler (tag, CATCHER);
if (EQ (tag, Qexit))
- minibuffer_quit_level = -1;
+ minibuffer_quit_level = 0;
/* Call FUNC. */
if (! sys_setjmp (c->jmp))
@@ -1194,22 +1205,16 @@ internal_catch (Lisp_Object tag,
Lisp_Object val = handlerlist->val;
clobbered_eassert (handlerlist == c);
handlerlist = handlerlist->next;
- if (EQ (tag, Qexit) && EQ (val, Qt))
+ if (EQ (tag, Qexit) && EQ (val, Qt) && minibuffer_quit_level > 0)
/* If we've thrown t to tag `exit' from within a minibuffer, we
exit all minibuffers more deeply nested than the current
one. */
{
- EMACS_INT mini_depth = this_minibuffer_depth (Qnil);
- if (mini_depth && mini_depth != minibuffer_quit_level)
- {
- if (minibuffer_quit_level == -1)
- minibuffer_quit_level = mini_depth;
- if (minibuffer_quit_level
- && (minibuf_level > minibuffer_quit_level))
- Fthrow (Qexit, Qt);
- }
+ if (minibuf_level > minibuffer_quit_level
+ && !NILP (Fminibuffer_innermost_command_loop_p (Qnil)))
+ Fthrow (Qexit, Qt);
else
- minibuffer_quit_level = -1;
+ minibuffer_quit_level = 0;
}
return val;
}
@@ -1305,7 +1310,7 @@ DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
doc: /* Regain control when an error is signaled.
Executes BODYFORM and returns its value if no error happens.
Each element of HANDLERS looks like (CONDITION-NAME BODY...)
-where the BODY is made of Lisp expressions.
+or (:success BODY...), where the BODY is made of Lisp expressions.
A handler is applicable to an error if CONDITION-NAME is one of the
error's condition names. Handlers may also apply when non-error
@@ -1327,6 +1332,10 @@ with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
Then the value of the last BODY form is returned from the `condition-case'
expression.
+The special handler (:success BODY...) is invoked if BODYFORM terminated
+without signalling an error. BODY is then evaluated with VAR bound to
+the value returned by BODYFORM.
+
See also the function `signal' for more info.
usage: (condition-case VAR BODYFORM &rest HANDLERS) */)
(Lisp_Object args)
@@ -1350,16 +1359,21 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
CHECK_SYMBOL (var);
+ Lisp_Object success_handler = Qnil;
+
for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
{
Lisp_Object tem = XCAR (tail);
- clausenb++;
if (! (NILP (tem)
|| (CONSP (tem)
&& (SYMBOLP (XCAR (tem))
|| CONSP (XCAR (tem))))))
error ("Invalid condition handler: %s",
SDATA (Fprin1_to_string (tem, Qt)));
+ if (CONSP (tem) && EQ (XCAR (tem), QCsuccess))
+ success_handler = XCDR (tem);
+ else
+ clausenb++;
}
/* The first clause is the one that should be checked first, so it
@@ -1373,7 +1387,11 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
Lisp_Object volatile *clauses = alloca (clausenb * sizeof *clauses);
clauses += clausenb;
for (Lisp_Object tail = handlers; CONSP (tail); tail = XCDR (tail))
- *--clauses = XCAR (tail);
+ {
+ Lisp_Object tem = XCAR (tail);
+ if (!(CONSP (tem) && EQ (XCAR (tem), QCsuccess)))
+ *--clauses = tem;
+ }
for (ptrdiff_t i = 0; i < clausenb; i++)
{
Lisp_Object clause = clauses[i];
@@ -1411,8 +1429,25 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform,
}
}
- Lisp_Object result = eval_sub (bodyform);
+ Lisp_Object CACHEABLE result = eval_sub (bodyform);
handlerlist = oldhandlerlist;
+ if (!NILP (success_handler))
+ {
+ if (NILP (var))
+ return Fprogn (success_handler);
+
+ Lisp_Object handler_var = var;
+ if (!NILP (Vinternal_interpreter_environment))
+ {
+ result = Fcons (Fcons (var, result),
+ Vinternal_interpreter_environment);
+ handler_var = Qinternal_interpreter_environment;
+ }
+
+ ptrdiff_t count = SPECPDL_INDEX ();
+ specbind (handler_var, result);
+ return unbind_to (count, Fprogn (success_handler));
+ }
return result;
}
@@ -1498,6 +1533,90 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
}
}
+/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3 as
+ its arguments. */
+
+Lisp_Object
+internal_condition_case_3 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
+ Lisp_Object),
+ Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
+ Lisp_Object handlers,
+ Lisp_Object (*hfun) (Lisp_Object))
+{
+ struct handler *c = push_handler (handlers, CONDITION_CASE);
+ if (sys_setjmp (c->jmp))
+ {
+ Lisp_Object val = handlerlist->val;
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return hfun (val);
+ }
+ else
+ {
+ Lisp_Object val = bfun (arg1, arg2, arg3);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+}
+
+/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, ARG4 as
+ its arguments. */
+
+Lisp_Object
+internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object),
+ Lisp_Object arg1, Lisp_Object arg2,
+ Lisp_Object arg3, Lisp_Object arg4,
+ Lisp_Object handlers,
+ Lisp_Object (*hfun) (Lisp_Object))
+{
+ struct handler *c = push_handler (handlers, CONDITION_CASE);
+ if (sys_setjmp (c->jmp))
+ {
+ Lisp_Object val = handlerlist->val;
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return hfun (val);
+ }
+ else
+ {
+ Lisp_Object val = bfun (arg1, arg2, arg3, arg4);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+}
+
+/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3,
+ ARG4, ARG5 as its arguments. */
+
+Lisp_Object
+internal_condition_case_5 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
+ Lisp_Object, Lisp_Object,
+ Lisp_Object),
+ Lisp_Object arg1, Lisp_Object arg2,
+ Lisp_Object arg3, Lisp_Object arg4,
+ Lisp_Object arg5, Lisp_Object handlers,
+ Lisp_Object (*hfun) (Lisp_Object))
+{
+ struct handler *c = push_handler (handlers, CONDITION_CASE);
+ if (sys_setjmp (c->jmp))
+ {
+ Lisp_Object val = handlerlist->val;
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return hfun (val);
+ }
+ else
+ {
+ Lisp_Object val = bfun (arg1, arg2, arg3, arg4, arg5);
+ eassert (handlerlist == c);
+ handlerlist = c->next;
+ return val;
+ }
+}
+
/* Like internal_condition_case but call BFUN with NARGS as first,
and ARGS as second argument. */
@@ -1907,6 +2026,18 @@ skip_debugger (Lisp_Object conditions, Lisp_Object data)
return 0;
}
+/* Say whether SIGNAL is a `quit' symbol (or inherits from it). */
+bool
+signal_quit_p (Lisp_Object signal)
+{
+ Lisp_Object list;
+
+ return EQ (signal, Qquit)
+ || (!NILP (Fsymbolp (signal))
+ && CONSP (list = Fget (signal, Qerror_conditions))
+ && !NILP (Fmemq (Qquit, list)));
+}
+
/* Call the debugger if calling it is currently enabled for CONDITIONS.
SIG and DATA describe the signal. There are two ways to pass them:
= SIG is the error symbol, and DATA is the rest of the data.
@@ -1925,7 +2056,7 @@ maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig, Lisp_Object data)
! input_blocked_p ()
&& NILP (Vinhibit_debugger)
/* Does user want to enter debugger for this kind of error? */
- && (EQ (sig, Qquit)
+ && (signal_quit_p (sig)
? debug_on_quit
: wants_debugger (Vdebug_on_error, conditions))
&& ! skip_debugger (conditions, combined_data)
@@ -2084,14 +2215,21 @@ then strings and vectors are not accepted. */)
DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
doc: /* Define FUNCTION to autoload from FILE.
FUNCTION is a symbol; FILE is a file name string to pass to `load'.
+
Third arg DOCSTRING is documentation for the function.
-Fourth arg INTERACTIVE if non-nil says function can be called interactively.
+
+Fourth arg INTERACTIVE if non-nil says function can be called
+interactively. If INTERACTIVE is a list, it is interpreted as a list
+of modes the function is applicable for.
+
Fifth arg TYPE indicates the type of the object:
nil or omitted says FUNCTION is a function,
`keymap' says FUNCTION is really a keymap, and
`macro' or t says FUNCTION is really a macro.
+
Third through fifth args give info about the real definition.
They default to nil.
+
If FUNCTION is already defined other than as an autoload,
this does nothing and returns nil. */)
(Lisp_Object function, Lisp_Object file, Lisp_Object docstring, Lisp_Object interactive, Lisp_Object type)
@@ -2326,7 +2464,7 @@ eval_sub (Lisp_Object form)
else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
fun = indirect_function (fun);
- if (SUBRP (fun))
+ if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun))
{
Lisp_Object args_left = original_args;
ptrdiff_t numargs = list_length (args_left);
@@ -2429,7 +2567,9 @@ eval_sub (Lisp_Object form)
}
}
}
- else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
+ else if (COMPILEDP (fun)
+ || SUBR_NATIVE_COMPILED_DYNP (fun)
+ || MODULE_FUNCTIONP (fun))
return apply_lambda (fun, original_args, count);
else
{
@@ -2907,9 +3047,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
&& (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
fun = indirect_function (fun);
- if (SUBRP (fun))
+ if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun))
val = funcall_subr (XSUBR (fun), numargs, args + 1);
- else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
+ else if (COMPILEDP (fun)
+ || SUBR_NATIVE_COMPILED_DYNP (fun)
+ || MODULE_FUNCTIONP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
{
@@ -3119,6 +3261,11 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
else if (MODULE_FUNCTIONP (fun))
return funcall_module (fun, nargs, arg_vector);
#endif
+ else if (SUBR_NATIVE_COMPILED_DYNP (fun))
+ {
+ syms_left = XSUBR (fun)->lambda_list[0];
+ lexenv = Qnil;
+ }
else
emacs_abort ();
@@ -3179,6 +3326,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
if (CONSP (fun))
val = Fprogn (XCDR (XCDR (fun)));
+ else if (SUBR_NATIVE_COMPILEDP (fun))
+ {
+ eassert (SUBR_NATIVE_COMPILED_DYNP (fun));
+ /* No need to use funcall_subr as we have zero arguments by
+ construction. */
+ val = XSUBR (fun)->function.a0 ();
+ }
else
val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL);
@@ -4378,6 +4532,7 @@ alist of active lexical bindings. */);
defsubr (&Sthrow);
defsubr (&Sunwind_protect);
defsubr (&Scondition_case);
+ DEFSYM (QCsuccess, ":success");
defsubr (&Ssignal);
defsubr (&Scommandp);
defsubr (&Sautoload);
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-03 15:55:38 +0000