From b6f95e5c0ae4415fbec0d327c05ac0417f99c84b Mon Sep 17 00:00:00 2001 From: Federico Tedin Date: Thu, 16 Sep 2021 23:31:27 +0200 Subject: [PATCH] WIP eval.c: apply_subr --- src/data.c | 2 +- src/eval.c | 165 ++++++++++++++++++----------------------------------- src/lisp.h | 2 +- 3 files changed, 57 insertions(+), 112 deletions(-) diff --git a/src/data.c b/src/data.c index 27b642df28..cc9e5b713b 100644 --- a/src/data.c +++ b/src/data.c @@ -1737,7 +1737,7 @@ notify_variable_watchers (Lisp_Object symbol, if (SUBRP (watcher)) { Lisp_Object args[] = { symbol, newval, operation, where }; - funcall_subr (XSUBR (watcher), ARRAYELTS (args), args); + funcall_subr (XSUBR (watcher), ARRAYELTS (args), args, false); } else CALLN (Ffuncall, watcher, symbol, newval, operation, where); diff --git a/src/eval.c b/src/eval.c index 48104bd0f4..a75cdb186b 100644 --- a/src/eval.c +++ b/src/eval.c @@ -65,6 +65,7 @@ Copyright (C) 1985-1987, 1993-1995, 1999-2021 Free Software Foundation, static Lisp_Object funcall_lambda (Lisp_Object, ptrdiff_t, Lisp_Object *); static Lisp_Object apply_lambda (Lisp_Object, Lisp_Object, ptrdiff_t); +static Lisp_Object apply_subr (struct Lisp_Subr *subr, Lisp_Object args, ptrdiff_t count); static Lisp_Object lambda_arity (Lisp_Object); static Lisp_Object @@ -2451,9 +2452,6 @@ eval_sub (Lisp_Object form) do_debug_on_call (Qt, count); Lisp_Object fun, val, funcar; - /* Declare here, as this array may be accessed by call_debugger near - the end of this function. See Bug#21245. */ - Lisp_Object argvals[8]; retry: @@ -2465,108 +2463,7 @@ eval_sub (Lisp_Object form) fun = indirect_function (fun); if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) - { - Lisp_Object args_left = original_args; - ptrdiff_t numargs = list_length (args_left); - - if (numargs < XSUBR (fun)->min_args - || (XSUBR (fun)->max_args >= 0 - && XSUBR (fun)->max_args < numargs)) - xsignal2 (Qwrong_number_of_arguments, original_fun, - make_fixnum (numargs)); - - else if (XSUBR (fun)->max_args == UNEVALLED) - val = (XSUBR (fun)->function.aUNEVALLED) (args_left); - else if (XSUBR (fun)->max_args == MANY) - { - /* Pass a vector of evaluated arguments. */ - Lisp_Object *vals; - ptrdiff_t argnum = 0; - USE_SAFE_ALLOCA; - - SAFE_ALLOCA_LISP (vals, numargs); - - while (CONSP (args_left) && argnum < numargs) - { - Lisp_Object arg = XCAR (args_left); - args_left = XCDR (args_left); - vals[argnum++] = eval_sub (arg); - } - - set_backtrace_args (specpdl + count, vals, argnum); - - val = XSUBR (fun)->function.aMANY (argnum, vals); - - lisp_eval_depth--; - /* Do the debug-on-exit now, while VALS still exists. */ - if (backtrace_debug_on_exit (specpdl + count)) - val = call_debugger (list2 (Qexit, val)); - SAFE_FREE (); - specpdl_ptr--; - return val; - } - else - { - int i, maxargs = XSUBR (fun)->max_args; - - for (i = 0; i < maxargs; i++) - { - argvals[i] = eval_sub (Fcar (args_left)); - args_left = Fcdr (args_left); - } - - set_backtrace_args (specpdl + count, argvals, numargs); - - switch (i) - { - case 0: - val = (XSUBR (fun)->function.a0 ()); - break; - case 1: - val = (XSUBR (fun)->function.a1 (argvals[0])); - break; - case 2: - val = (XSUBR (fun)->function.a2 (argvals[0], argvals[1])); - break; - case 3: - val = (XSUBR (fun)->function.a3 - (argvals[0], argvals[1], argvals[2])); - break; - case 4: - val = (XSUBR (fun)->function.a4 - (argvals[0], argvals[1], argvals[2], argvals[3])); - break; - case 5: - val = (XSUBR (fun)->function.a5 - (argvals[0], argvals[1], argvals[2], argvals[3], - argvals[4])); - break; - case 6: - val = (XSUBR (fun)->function.a6 - (argvals[0], argvals[1], argvals[2], argvals[3], - argvals[4], argvals[5])); - break; - case 7: - val = (XSUBR (fun)->function.a7 - (argvals[0], argvals[1], argvals[2], argvals[3], - argvals[4], argvals[5], argvals[6])); - break; - - case 8: - val = (XSUBR (fun)->function.a8 - (argvals[0], argvals[1], argvals[2], argvals[3], - argvals[4], argvals[5], argvals[6], argvals[7])); - break; - - default: - /* Someone has created a subr that takes more arguments than - is supported by this code. We need to either rewrite the - subr to use a different argument protocol, or add more - cases to this switch. */ - emacs_abort (); - } - } - } + return apply_subr (XSUBR (fun), original_args, count); else if (COMPILEDP (fun) || SUBR_NATIVE_COMPILED_DYNP (fun) || MODULE_FUNCTIONP (fun)) @@ -3048,7 +2945,7 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, fun = indirect_function (fun); if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) - val = funcall_subr (XSUBR (fun), numargs, args + 1); + val = funcall_subr (XSUBR (fun), numargs, args + 1, false); else if (COMPILEDP (fun) || SUBR_NATIVE_COMPILED_DYNP (fun) || MODULE_FUNCTIONP (fun)) @@ -3081,11 +2978,52 @@ DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0, } +static Lisp_Object +apply_subr (struct Lisp_Subr *subr, Lisp_Object args, ptrdiff_t count) +{ + Lisp_Object *arg_vector; + Lisp_Object tem; + USE_SAFE_ALLOCA; + + ptrdiff_t numargs = list_length (args); + + if (subr->max_args != UNEVALLED) + { + Lisp_Object args_left = args; + SAFE_ALLOCA_LISP (arg_vector, numargs); + + for (ptrdiff_t i = 0; i < numargs; i++) + { + tem = Fcar (args_left); + args_left = Fcdr(args_left); + tem = eval_sub(tem); + + arg_vector[i] = tem; + } + } + else + { + SAFE_ALLOCA_LISP (arg_vector, 1); + arg_vector[0] = args; + } + + set_backtrace_args (specpdl + count, arg_vector, subr->max_args != UNEVALLED ? numargs : 1); + tem = funcall_subr (subr, numargs, arg_vector, true); + + lisp_eval_depth--; + + if (backtrace_debug_on_exit (specpdl + count)) + tem = call_debugger (list2 (Qexit, tem)); + SAFE_FREE (); + specpdl_ptr--; + return tem; +} + /* Apply a C subroutine SUBR to the NUMARGS evaluated arguments in ARG_VECTOR and return the result of evaluation. */ Lisp_Object -funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) +funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args, bool unevalled_ok) { if (numargs < subr->min_args || (subr->max_args >= 0 && subr->max_args < numargs)) @@ -3097,9 +3035,16 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) else if (subr->max_args == UNEVALLED) { - Lisp_Object fun; - XSETSUBR (fun, subr); - xsignal1 (Qinvalid_function, fun); + if (unevalled_ok) + { + return (subr->function.aUNEVALLED (args[0])); + } + else + { + Lisp_Object fun; + XSETSUBR (fun, subr); + xsignal1 (Qinvalid_function, fun); + } } else if (subr->max_args == MANY) diff --git a/src/lisp.h b/src/lisp.h index 7bfc69b647..e0c056a5bb 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4145,7 +4145,7 @@ xsignal (Lisp_Object error_symbol, Lisp_Object data) extern AVOID signal_error (const char *, Lisp_Object); extern AVOID overflow_error (void); extern bool FUNCTIONP (Lisp_Object); -extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *arg_vector); +extern Lisp_Object funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *arg_vector, bool unevalled_ok); extern Lisp_Object eval_sub (Lisp_Object form); extern Lisp_Object apply1 (Lisp_Object, Lisp_Object); extern Lisp_Object call0 (Lisp_Object); -- 2.25.1