#include <config.h>
+#include <limits.h>
#include <setjmp.h>
+#include <stdio.h>
#include "lisp.h"
#include "blockinput.h"
#include "commands.h"
#include "xterm.h"
#endif
-/* This definition is duplicated in alloc.c and keyboard.c */
-/* Putting it in lisp.h makes cc bomb out! */
+#ifndef SIZE_MAX
+# define SIZE_MAX ((size_t) -1)
+#endif
+
+/* This definition is duplicated in alloc.c and keyboard.c. */
+/* Putting it in lisp.h makes cc bomb out! */
struct backtrace
{
struct backtrace *next;
Lisp_Object *function;
- Lisp_Object *args; /* Points to vector of args. */
- int nargs; /* Length of vector.
- If nargs is UNEVALLED, args points to slot holding
- list of unevalled args */
- char evalargs;
- /* Nonzero means call value of debugger when done with this operation. */
- char debug_on_exit;
+ Lisp_Object *args; /* Points to vector of args. */
+#define NARGS_BITS (BITS_PER_INT - 2)
+ /* Let's not use size_t because we want to allow negative values (for
+ UNEVALLED). Also let's steal 2 bits so we save a word (or more for
+ alignment). In any case I doubt Emacs would survive a function call with
+ more than 500M arguments. */
+ int nargs : NARGS_BITS; /* Length of vector.
+ If nargs is UNEVALLED, args points
+ to slot holding list of unevalled args. */
+ char evalargs : 1;
+ /* Nonzero means call value of debugger when done with this operation. */
+ char debug_on_exit : 1;
};
-struct backtrace *backtrace_list;
+static struct backtrace *backtrace_list;
+#if !BYTE_MARK_STACK
+static
+#endif
struct catchtag *catchlist;
+/* Chain of condition handlers currently in effect.
+ The elements of this chain are contained in the stack frames
+ of Fcondition_case and internal_condition_case.
+ When an error is signaled (by calling Fsignal, below),
+ this chain is searched for an element that applies. */
+
+#if !BYTE_MARK_STACK
+static
+#endif
+struct handler *handlerlist;
+
#ifdef DEBUG_GCPRO
/* Count levels of GCPRO to detect failure to UNGCPRO. */
int gcpro_level;
Lisp_Object Qautoload, Qmacro, Qexit, Qinteractive, Qcommandp, Qdefun;
Lisp_Object Qinhibit_quit;
-Lisp_Object Qand_rest, Qand_optional;
-Lisp_Object Qdebug_on_error;
-Lisp_Object Qdeclare;
+Lisp_Object Qand_rest;
+static Lisp_Object Qand_optional;
+static Lisp_Object Qdebug_on_error;
+static Lisp_Object Qdeclare;
Lisp_Object Qinternal_interpreter_environment, Qclosure;
Lisp_Object Qdebug;
/* Depth in Lisp evaluations and function calls. */
-EMACS_INT lisp_eval_depth;
+static EMACS_INT lisp_eval_depth;
/* The value of num_nonmacro_input_events as of the last time we
started to enter the debugger. If we decide to enter the debugger
signal the error instead of entering an infinite loop of debugger
invocations. */
-int when_entered_debugger;
+static int when_entered_debugger;
/* The function from which the last `signal' was called. Set in
Fsignal. */
int handling_signal;
-static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
-static Lisp_Object funcall_lambda (Lisp_Object, int, Lisp_Object *);
+static Lisp_Object funcall_lambda (Lisp_Object, size_t, Lisp_Object *);
static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN;
static int interactive_p (int);
+static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args);
+static Lisp_Object Ffetch_bytecode (Lisp_Object);
\f
void
init_eval_once (void)
when_entered_debugger = -1;
}
-/* unwind-protect function used by call_debugger. */
+/* Unwind-protect function used by call_debugger. */
static Lisp_Object
restore_stack_limits (Lisp_Object data)
/* Call the Lisp debugger, giving it argument ARG. */
-Lisp_Object
+static Lisp_Object
call_debugger (Lisp_Object arg)
{
int debug_while_redisplaying;
return unbind_to (count, val);
}
-void
+static void
do_debug_on_call (Lisp_Object code)
{
debug_on_next_call = 0;
do
{
+ Lisp_Object tem = eval_sub (XCAR (args_left));
if (!(argnum++))
- val = eval_sub (Fcar (args_left));
- else
- eval_sub (Fcar (args_left));
- args_left = Fcdr (args_left);
+ val = tem;
+ args_left = XCDR (args_left);
}
- while (!NILP(args_left));
+ while (CONSP (args_left));
UNGCPRO;
return val;
do
{
+ Lisp_Object tem = eval_sub (XCAR (args_left));
if (!(argnum++))
- val = eval_sub (Fcar (args_left));
- else
- eval_sub (Fcar (args_left));
- args_left = Fcdr (args_left);
+ val = tem;
+ args_left = XCDR (args_left);
}
- while (!NILP (args_left));
+ while (CONSP (args_left));
UNGCPRO;
return val;
&& EQ (XCAR (quoted), Qlambda))
/* This is a lambda expression within a lexical environment;
return an interpreted closure instead of a simple lambda. */
- return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment, quoted));
+ return Fcons (Qclosure, Fcons (Vinternal_interpreter_environment,
+ XCDR (quoted)));
else
/* Simply quote the argument. */
return quoted;
|| btp->nargs == UNEVALLED))
btp = btp->next;
- /* btp now points at the frame of the innermost function that isn't
+ /* `btp' now points at the frame of the innermost function that isn't
a special form, ignoring frames for Finteractive_p and/or
Fbytecode at the top. If this frame is for a built-in function
(such as load or eval-region) return nil. */
if (exclude_subrs_p && SUBRP (fun))
return 0;
- /* btp points to the frame of a Lisp function that called interactive-p.
+ /* `btp' points to the frame of a Lisp function that called interactive-p.
Return t if that function was called interactively. */
if (btp && btp->next && EQ (*btp->next->function, Qcall_interactively))
return 1;
tail = Fcons (lambda_list, tail);
else
tail = Fcons (lambda_list, Fcons (doc, tail));
-
+
defn = Fcons (Qlambda, tail);
if (!NILP (Vinternal_interpreter_environment)) /* Mere optimization! */
defn = Ffunction (Fcons (defn, Qnil));
tem = Fdefault_boundp (sym);
if (!NILP (tail))
{
- if (SYMBOLP (sym))
- /* Do it before evaluating the initial value, for self-references. */
- XSYMBOL (sym)->declared_special = 1;
+ /* Do it before evaluating the initial value, for self-references. */
+ XSYMBOL (sym)->declared_special = 1;
if (SYMBOL_CONSTANT_P (sym))
{
/* For upward compatibility, allow (defvar :foo (quote :foo)). */
- Lisp_Object tem = Fcar (tail);
- if (! (CONSP (tem)
- && EQ (XCAR (tem), Qquote)
- && CONSP (XCDR (tem))
- && EQ (XCAR (XCDR (tem)), sym)))
+ Lisp_Object tem1 = Fcar (tail);
+ if (! (CONSP (tem1)
+ && EQ (XCAR (tem1), Qquote)
+ && CONSP (XCDR (tem1))
+ && EQ (XCAR (XCDR (tem1)), sym)))
error ("Constant symbol `%s' specified in defvar",
SDATA (SYMBOL_NAME (sym)));
}
Vinternal_interpreter_environment =
Fcons (sym, Vinternal_interpreter_environment);
else
- /* Simple (defvar <var>) should not count as a definition at all.
- It could get in the way of other definitions, and unloading this
- package could try to make the variable unbound. */
- ;
-
+ {
+ /* Simple (defvar <var>) should not count as a definition at all.
+ It could get in the way of other definitions, and unloading this
+ package could try to make the variable unbound. */
+ }
+
return sym;
}
static Lisp_Object
lisp_indirect_variable (Lisp_Object sym)
{
- XSETSYMBOL (sym, indirect_variable (XSYMBOL (sym)));
+ struct Lisp_Symbol *s = indirect_variable (XSYMBOL (sym));
+ XSETSYMBOL (sym, s);
return sym;
}
varlist = XCDR (varlist);
}
-
UNGCPRO;
-
val = Fprogn (Fcdr (args));
-
return unbind_to (count, val);
}
Lisp_Object *temps, tem, lexenv;
register Lisp_Object elt, varlist;
int count = SPECPDL_INDEX ();
- register int argnum;
+ register size_t argnum;
struct gcpro gcpro1, gcpro2;
USE_SAFE_ALLOCA;
varlist = Fcar (args);
- /* Make space to hold the values to give the bound variables */
+ /* Make space to hold the values to give the bound variables. */
elt = Flength (varlist);
SAFE_ALLOCA_LISP (temps, XFASTINT (elt));
- /* Compute the values and store them in `temps' */
+ /* Compute the values and store them in `temps'. */
GCPRO2 (args, *temps);
gcpro2.nvars = 0;
/* SYM is not mentioned in ENVIRONMENT.
Look at its function definition. */
if (EQ (def, Qunbound) || !CONSP (def))
- /* Not defined or definition not suitable */
+ /* Not defined or definition not suitable. */
break;
if (EQ (XCAR (def), Qautoload))
{
byte_stack_list = catch->byte_stack;
gcprolist = catch->gcpro;
#ifdef DEBUG_GCPRO
- if (gcprolist != 0)
- gcpro_level = gcprolist->level + 1;
- else
- gcpro_level = 0;
+ gcpro_level = gcprolist ? gcprolist->level + 1 : 0;
#endif
backtrace_list = catch->backlist;
lisp_eval_depth = catch->lisp_eval_depth;
return unbind_to (count, val);
}
\f
-/* Chain of condition handlers currently in effect.
- The elements of this chain are contained in the stack frames
- of Fcondition_case and internal_condition_case.
- When an error is signaled (by calling Fsignal, below),
- this chain is searched for an element that applies. */
-
-struct handler *handlerlist;
-
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.
|| (CONSP (tem)
&& (SYMBOLP (XCAR (tem))
|| CONSP (XCAR (tem))))))
- error ("Invalid condition handler", tem);
+ error ("Invalid condition handler: %s",
+ SDATA (Fprin1_to_string (tem, Qt)));
}
c.tag = Qnil;
and ARGS as second argument. */
Lisp_Object
-internal_condition_case_n (Lisp_Object (*bfun) (int, Lisp_Object*),
- int nargs,
+internal_condition_case_n (Lisp_Object (*bfun) (size_t, Lisp_Object *),
+ size_t nargs,
Lisp_Object *args,
Lisp_Object handlers,
Lisp_Object (*hfun) (Lisp_Object))
if (!NILP (clause))
break;
}
-
+
if (/* Don't run the debugger for a memory-full error.
(There is no room in memory to do that!) */
!NILP (error_symbol)
can continue code which has signaled a quit. */
if (debugger_called && EQ (real_error_symbol, Qquit))
return Qnil;
- }
+ }
if (!NILP (clause))
{
Lisp_Object unwind_data
= (NILP (error_symbol) ? data : Fcons (error_symbol, data));
-
+
h->chosen_clause = clause;
unwind_to_catch (h->tag, unwind_data);
}
if (! NILP (error_symbol))
data = Fcons (error_symbol, data);
-
+
string = Ferror_message_string (data);
- fatal ("%s", SDATA (string), 0);
+ fatal ("%s", SDATA (string));
}
/* Internal version of Fsignal that never returns.
? debug_on_quit
: wants_debugger (Vdebug_on_error, conditions))
&& ! skip_debugger (conditions, combined_data)
- /* rms: what's this for? */
+ /* RMS: What's this for? */
&& when_entered_debugger < num_nonmacro_input_events)
{
call_debugger (Fcons (Qerror, Fcons (combined_data, Qnil)));
}
-/* dump an error message; called like vprintf */
+/* Dump an error message; called like vprintf. */
void
verror (const char *m, va_list ap)
{
- char buf[200];
- EMACS_INT size = 200;
- int mlen;
+ char buf[4000];
+ size_t size = sizeof buf;
+ size_t size_max = min (MOST_POSITIVE_FIXNUM, SIZE_MAX);
+ size_t mlen = strlen (m);
char *buffer = buf;
- int allocated = 0;
+ size_t used;
Lisp_Object string;
- mlen = strlen (m);
-
while (1)
{
- EMACS_INT used;
used = doprnt (buffer, size, m, m + mlen, ap);
- if (used < size)
+
+ /* Note: the -1 below is because `doprnt' returns the number of bytes
+ excluding the terminating null byte, and it always terminates with a
+ null byte, even when producing a truncated message. */
+ if (used < size - 1)
break;
- size *= 2;
- if (allocated)
- buffer = (char *) xrealloc (buffer, size);
+ if (size <= size_max / 2)
+ size *= 2;
+ else if (size < size_max)
+ size = size_max;
else
- {
- buffer = (char *) xmalloc (size);
- allocated = 1;
- }
+ break; /* and leave the message truncated */
+
+ if (buffer != buf)
+ xfree (buffer);
+ buffer = (char *) xmalloc (size);
}
- string = build_string (buffer);
- if (allocated)
+ string = make_string (buffer, used);
+ if (buffer != buf)
xfree (buffer);
xsignal1 (Qerror, string);
}
-/* dump an error message; called like printf */
+/* Dump an error message; called like printf. */
/* VARARGS 1 */
void
return Qnil;
funcar = XCAR (fun);
if (EQ (funcar, Qclosure))
- fun = Fcdr (XCDR (fun)), funcar = Fcar (fun);
- if (EQ (funcar, Qlambda))
+ return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))))
+ ? Qt : if_prop);
+ else if (EQ (funcar, Qlambda))
return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
else if (EQ (funcar, Qautoload))
return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
CHECK_SYMBOL (function);
CHECK_STRING (file);
- /* If function is defined and not as an autoload, don't override */
+ /* If function is defined and not as an autoload, don't override. */
if (!EQ (XSYMBOL (function)->function, Qunbound)
&& !(CONSP (XSYMBOL (function)->function)
&& EQ (XCAR (XSYMBOL (function)->function), Qautoload)))
backtrace.next = backtrace_list;
backtrace_list = &backtrace;
- backtrace.function = &original_fun; /* This also protects them from gc */
+ backtrace.function = &original_fun; /* This also protects them from gc. */
backtrace.args = &original_args;
backtrace.nargs = UNEVALLED;
backtrace.evalargs = 1;
do_debug_on_call (Qt);
/* At this point, only original_fun and original_args
- have values that will be used below */
+ have values that will be used below. */
retry:
/* Optimize for no indirection. */
CHECK_CONS_LIST ();
- if (XINT (numargs) < XSUBR (fun)->min_args ||
- (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs)))
+ if (XINT (numargs) < XSUBR (fun)->min_args
+ || (XSUBR (fun)->max_args >= 0
+ && XSUBR (fun)->max_args < XINT (numargs)))
xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
else if (XSUBR (fun)->max_args == UNEVALLED)
}
else if (XSUBR (fun)->max_args == MANY)
{
- /* Pass a vector of evaluated arguments */
+ /* Pass a vector of evaluated arguments. */
Lisp_Object *vals;
- register int argnum = 0;
+ register size_t argnum = 0;
USE_SAFE_ALLOCA;
SAFE_ALLOCA_LISP (vals, XINT (numargs));
Then return the value FUNCTION returns.
Thus, (apply '+ 1 2 '(3 4)) returns 10.
usage: (apply FUNCTION &rest ARGUMENTS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
- register int i, numargs;
+ register size_t i, numargs;
register Lisp_Object spread_arg;
register Lisp_Object *funcall_args;
Lisp_Object fun, retval;
fun = indirect_function (fun);
if (EQ (fun, Qunbound))
{
- /* Let funcall get the error */
+ /* Let funcall get the error. */
fun = args[0];
goto funcall;
}
{
if (numargs < XSUBR (fun)->min_args
|| (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
- goto funcall; /* Let funcall get the error */
- else if (XSUBR (fun)->max_args > numargs)
+ goto funcall; /* Let funcall get the error. */
+ else if (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args > numargs)
{
/* Avoid making funcall cons up a yet another new vector of arguments
- by explicitly supplying nil's for optional values */
+ by explicitly supplying nil's for optional values. */
SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
for (i = numargs; i < XSUBR (fun)->max_args;)
funcall_args[++i] = Qnil;
\f
/* Run hook variables in various ways. */
-enum run_hooks_condition {to_completion, until_success, until_failure};
-static Lisp_Object run_hook_with_args (int, Lisp_Object *,
- enum run_hooks_condition);
+static Lisp_Object
+funcall_nil (size_t nargs, Lisp_Object *args)
+{
+ Ffuncall (nargs, args);
+ return Qnil;
+}
DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
doc: /* Run each hook in HOOKS.
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument.
usage: (run-hooks &rest HOOKS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
Lisp_Object hook[1];
- register int i;
+ register size_t i;
for (i = 0; i < nargs; i++)
{
hook[0] = args[i];
- run_hook_with_args (1, hook, to_completion);
+ run_hook_with_args (1, hook, funcall_nil);
}
return Qnil;
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument.
usage: (run-hook-with-args HOOK &rest ARGS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
- return run_hook_with_args (nargs, args, to_completion);
+ return run_hook_with_args (nargs, args, funcall_nil);
}
DEFUN ("run-hook-with-args-until-success", Frun_hook_with_args_until_success,
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument.
usage: (run-hook-with-args-until-success HOOK &rest ARGS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
+{
+ return run_hook_with_args (nargs, args, Ffuncall);
+}
+
+static Lisp_Object
+funcall_not (size_t nargs, Lisp_Object *args)
{
- return run_hook_with_args (nargs, args, until_success);
+ return NILP (Ffuncall (nargs, args)) ? Qt : Qnil;
}
DEFUN ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure,
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument.
usage: (run-hook-with-args-until-failure HOOK &rest ARGS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
+{
+ return NILP (run_hook_with_args (nargs, args, funcall_not)) ? Qt : Qnil;
+}
+
+static Lisp_Object
+run_hook_wrapped_funcall (size_t nargs, Lisp_Object *args)
+{
+ Lisp_Object tmp = args[0], ret;
+ args[0] = args[1];
+ args[1] = tmp;
+ ret = Ffuncall (nargs, args);
+ args[1] = args[0];
+ args[0] = tmp;
+ return ret;
+}
+
+DEFUN ("run-hook-wrapped", Frun_hook_wrapped, Srun_hook_wrapped, 2, MANY, 0,
+ doc: /* Run HOOK, passing each function through WRAP-FUNCTION.
+I.e. instead of calling each function FUN directly with arguments ARGS,
+it calls WRAP-FUNCTION with arguments FUN and ARGS.
+As soon as a call to WRAP-FUNCTION returns non-nil, `run-hook-wrapped'
+aborts and returns that value.
+usage: (run-hook-wrapped HOOK WRAP-FUNCTION &rest ARGS) */)
+ (size_t nargs, Lisp_Object *args)
{
- return run_hook_with_args (nargs, args, until_failure);
+ return run_hook_with_args (nargs, args, run_hook_wrapped_funcall);
}
/* ARGS[0] should be a hook symbol.
Call each of the functions in the hook value, passing each of them
as arguments all the rest of ARGS (all NARGS - 1 elements).
- COND specifies a condition to test after each call
- to decide whether to stop.
+ FUNCALL specifies how to call each function on the hook.
The caller (or its caller, etc) must gcpro all of ARGS,
except that it isn't necessary to gcpro ARGS[0]. */
-static Lisp_Object
-run_hook_with_args (int nargs, Lisp_Object *args, enum run_hooks_condition cond)
+Lisp_Object
+run_hook_with_args (size_t nargs, Lisp_Object *args,
+ Lisp_Object (*funcall) (size_t nargs, Lisp_Object *args))
{
- Lisp_Object sym, val, ret;
+ Lisp_Object sym, val, ret = Qnil;
struct gcpro gcpro1, gcpro2, gcpro3;
/* If we are dying or still initializing,
sym = args[0];
val = find_symbol_value (sym);
- ret = (cond == until_failure ? Qt : Qnil);
if (EQ (val, Qunbound) || NILP (val))
return ret;
else if (!CONSP (val) || EQ (XCAR (val), Qlambda))
{
args[0] = val;
- return Ffuncall (nargs, args);
+ return funcall (nargs, args);
}
else
{
- Lisp_Object globals = Qnil;
- GCPRO3 (sym, val, globals);
+ Lisp_Object global_vals = Qnil;
+ GCPRO3 (sym, val, global_vals);
for (;
- CONSP (val) && ((cond == to_completion)
- || (cond == until_success ? NILP (ret)
- : !NILP (ret)));
+ CONSP (val) && NILP (ret);
val = XCDR (val))
{
if (EQ (XCAR (val), Qt))
{
/* t indicates this hook has a local binding;
it means to run the global binding too. */
- globals = Fdefault_value (sym);
- if (NILP (globals)) continue;
+ global_vals = Fdefault_value (sym);
+ if (NILP (global_vals)) continue;
- if (!CONSP (globals) || EQ (XCAR (globals), Qlambda))
+ if (!CONSP (global_vals) || EQ (XCAR (global_vals), Qlambda))
{
- args[0] = globals;
- ret = Ffuncall (nargs, args);
+ args[0] = global_vals;
+ ret = funcall (nargs, args);
}
else
{
for (;
- CONSP (globals) && ((cond == to_completion)
- || (cond == until_success ? NILP (ret)
- : !NILP (ret)));
- globals = XCDR (globals))
+ CONSP (global_vals) && NILP (ret);
+ global_vals = XCDR (global_vals))
{
- args[0] = XCAR (globals);
+ args[0] = XCAR (global_vals);
/* In a global value, t should not occur. If it does, we
must ignore it to avoid an endless loop. */
if (!EQ (args[0], Qt))
- ret = Ffuncall (nargs, args);
+ ret = funcall (nargs, args);
}
}
}
else
{
args[0] = XCAR (val);
- ret = Ffuncall (nargs, args);
+ ret = funcall (nargs, args);
}
}
Frun_hook_with_args (3, temp);
}
\f
-/* Apply fn to arg */
+/* Apply fn to arg. */
Lisp_Object
apply1 (Lisp_Object fn, Lisp_Object arg)
{
}
}
-/* Call function fn on no arguments */
+/* Call function fn on no arguments. */
Lisp_Object
call0 (Lisp_Object fn)
{
RETURN_UNGCPRO (Ffuncall (1, &fn));
}
-/* Call function fn with 1 argument arg1 */
+/* Call function fn with 1 argument arg1. */
/* ARGSUSED */
Lisp_Object
call1 (Lisp_Object fn, Lisp_Object arg1)
RETURN_UNGCPRO (Ffuncall (2, args));
}
-/* Call function fn with 2 arguments arg1, arg2 */
+/* Call function fn with 2 arguments arg1, arg2. */
/* ARGSUSED */
Lisp_Object
call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2)
RETURN_UNGCPRO (Ffuncall (3, args));
}
-/* Call function fn with 3 arguments arg1, arg2, arg3 */
+/* Call function fn with 3 arguments arg1, arg2, arg3. */
/* ARGSUSED */
Lisp_Object
call3 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3)
RETURN_UNGCPRO (Ffuncall (4, args));
}
-/* Call function fn with 4 arguments arg1, arg2, arg3, arg4 */
+/* Call function fn with 4 arguments arg1, arg2, arg3, arg4. */
/* ARGSUSED */
Lisp_Object
call4 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
RETURN_UNGCPRO (Ffuncall (5, args));
}
-/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5 */
+/* Call function fn with 5 arguments arg1, arg2, arg3, arg4, arg5. */
/* ARGSUSED */
Lisp_Object
call5 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
RETURN_UNGCPRO (Ffuncall (6, args));
}
-/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6 */
+/* Call function fn with 6 arguments arg1, arg2, arg3, arg4, arg5, arg6. */
/* ARGSUSED */
Lisp_Object
call6 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
RETURN_UNGCPRO (Ffuncall (7, args));
}
-/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7 */
+/* Call function fn with 7 arguments arg1, arg2, arg3, arg4, arg5, arg6, arg7. */
/* ARGSUSED */
Lisp_Object
call7 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
/* The caller should GCPRO all the elements of ARGS. */
DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
- doc: /* Return non-nil if OBJECT is a type of object that can be called as a function. */)
+ doc: /* Non-nil if OBJECT is a function. */)
(Lisp_Object object)
{
if (SYMBOLP (object) && !NILP (Ffboundp (object)))
{
- object = Findirect_function (object, Qnil);
+ object = Findirect_function (object, Qt);
if (CONSP (object) && EQ (XCAR (object), Qautoload))
{
Return the value that function returns.
Thus, (funcall 'cons 'x 'y) returns (x . y).
usage: (funcall FUNCTION &rest ARGUMENTS) */)
- (int nargs, Lisp_Object *args)
+ (size_t nargs, Lisp_Object *args)
{
Lisp_Object fun, original_fun;
Lisp_Object funcar;
- int numargs = nargs - 1;
+ size_t numargs = nargs - 1;
Lisp_Object lisp_numargs;
Lisp_Object val;
struct backtrace backtrace;
register Lisp_Object *internal_args;
- register int i;
+ register size_t i;
QUIT;
if ((consing_since_gc > gc_cons_threshold
apply_lambda (Lisp_Object fun, Lisp_Object args)
{
Lisp_Object args_left;
- Lisp_Object numargs;
+ size_t numargs;
register Lisp_Object *arg_vector;
struct gcpro gcpro1, gcpro2, gcpro3;
- register int i;
+ register size_t i;
register Lisp_Object tem;
USE_SAFE_ALLOCA;
- numargs = Flength (args);
- SAFE_ALLOCA_LISP (arg_vector, XINT (numargs));
+ numargs = XINT (Flength (args));
+ SAFE_ALLOCA_LISP (arg_vector, numargs);
args_left = args;
GCPRO3 (*arg_vector, args_left, fun);
gcpro1.nvars = 0;
- for (i = 0; i < XINT (numargs);)
+ for (i = 0; i < numargs; )
{
tem = Fcar (args_left), args_left = Fcdr (args_left);
tem = eval_sub (tem);
backtrace_list->args = arg_vector;
backtrace_list->nargs = i;
backtrace_list->evalargs = 0;
- tem = funcall_lambda (fun, XINT (numargs), arg_vector);
+ tem = funcall_lambda (fun, numargs, arg_vector);
/* Do the debug-on-exit now, while arg_vector still exists. */
if (backtrace_list->debug_on_exit)
FUN must be either a lambda-expression or a compiled-code object. */
static Lisp_Object
-funcall_lambda (Lisp_Object fun, int nargs,
+funcall_lambda (Lisp_Object fun, size_t nargs,
register Lisp_Object *arg_vector)
{
Lisp_Object val, syms_left, next, lexenv;
int count = SPECPDL_INDEX ();
- int i, optional, rest;
+ size_t i;
+ int optional, rest;
if (CONSP (fun))
{
{
fun = XCDR (fun); /* Drop `closure'. */
lexenv = XCAR (fun);
- fun = XCDR (fun); /* Drop the lexical environment. */
+ CHECK_LIST_CONS (fun, fun);
}
else
lexenv = Qnil;
optional = 1;
else
{
- Lisp_Object val;
+ Lisp_Object arg;
if (rest)
{
- val = Flist (nargs - i, &arg_vector[i]);
+ arg = Flist (nargs - i, &arg_vector[i]);
i = nargs;
}
else if (i < nargs)
- val = arg_vector[i++];
+ arg = arg_vector[i++];
else if (!optional)
xsignal2 (Qwrong_number_of_arguments, fun, make_number (nargs));
else
- val = Qnil;
-
+ arg = Qnil;
+
/* Bind the argument. */
if (!NILP (lexenv) && SYMBOLP (next))
/* Lexically bind NEXT by adding it to the lexenv alist. */
- lexenv = Fcons (Fcons (next, val), lexenv);
+ lexenv = Fcons (Fcons (next, arg), lexenv);
else
/* Dynamically bind NEXT. */
- specbind (next, val);
+ specbind (next, arg);
}
}
return object;
}
\f
-void
+static void
grow_specpdl (void)
{
register int count = SPECPDL_INDEX ();
specpdl_ptr = specpdl + count;
}
-/* specpdl_ptr->symbol is a field which describes which variable is
+/* `specpdl_ptr->symbol' is a field which describes which variable is
let-bound, so it can be properly undone when we unbind_to.
It can have the following two shapes:
- SYMBOL : if it's a plain symbol, it means that we have let-bound
return value;
}
-\f
-
DEFUN ("special-variable-p", Fspecial_variable_p, Sspecial_variable_p, 1, 1, 0,
doc: /* Return non-nil if SYMBOL's global binding has been declared special.
A special variable is one that will be bound dynamically, even in a
}
\f
-
DEFUN ("backtrace-debug", Fbacktrace_debug, Sbacktrace_debug, 2, 2, 0,
doc: /* Set the debug-on-exit flag of eval frame LEVEL levels down to FLAG.
The debugger is entered when that frame exits, if the flag is non-nil. */)
(void)
{
register struct backtrace *backlist = backtrace_list;
- register int i;
Lisp_Object tail;
Lisp_Object tem;
struct gcpro gcpro1;
else
{
tem = *backlist->function;
- Fprin1 (tem, Qnil); /* This can QUIT */
+ Fprin1 (tem, Qnil); /* This can QUIT. */
write_string ("(", -1);
if (backlist->nargs == MANY)
- {
+ { /* FIXME: Can this happen? */
+ int i;
for (tail = *backlist->args, i = 0;
!NILP (tail);
- tail = Fcdr (tail), i++)
+ tail = Fcdr (tail), i = 1)
{
if (i) write_string (" ", -1);
Fprin1 (Fcar (tail), Qnil);
}
else
{
+ size_t i;
for (i = 0; i < backlist->nargs; i++)
{
if (i) write_string (" ", -1);
(Lisp_Object nframes)
{
register struct backtrace *backlist = backtrace_list;
- register int i;
+ register EMACS_INT i;
Lisp_Object tem;
CHECK_NATNUM (nframes);
return Fcons (Qnil, Fcons (*backlist->function, *backlist->args));
else
{
- if (backlist->nargs == MANY)
+ if (backlist->nargs == MANY) /* FIXME: Can this happen? */
tem = *backlist->args;
else
tem = Flist (backlist->nargs, backlist->args);
}
\f
+#if BYTE_MARK_STACK
void
mark_backtrace (void)
{
register struct backtrace *backlist;
- register int i;
+ register size_t i;
for (backlist = backtrace_list; backlist; backlist = backlist->next)
{
mark_object (*backlist->function);
- if (backlist->nargs == UNEVALLED || backlist->nargs == MANY)
- i = 0;
+ if (backlist->nargs == UNEVALLED
+ || backlist->nargs == MANY) /* FIXME: Can this happen? */
+ i = 1;
else
- i = backlist->nargs - 1;
- for (; i >= 0; i--)
+ i = backlist->nargs;
+ while (i--)
mark_object (backlist->args[i]);
}
}
-
-EXFUN (Funintern, 2);
+#endif
void
syms_of_eval (void)
defsubr (&Srun_hook_with_args);
defsubr (&Srun_hook_with_args_until_success);
defsubr (&Srun_hook_with_args_until_failure);
+ defsubr (&Srun_hook_wrapped);
defsubr (&Sfetch_bytecode);
defsubr (&Sbacktrace_debug);
defsubr (&Sbacktrace);
defsubr (&Sspecial_variable_p);
defsubr (&Sfunctionp);
}
-
HCoop / bpt / emacs.git / blobdiff