#include <config.h>
+#include <limits.h>
#include <setjmp.h>
#include "lisp.h"
#include "blockinput.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;
-
struct catchtag *catchlist;
#ifdef DEBUG_GCPRO
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 Qcurry;
+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;
+static Lisp_Object Qdebug;
/* This holds either the symbol `run-hooks' or nil.
It is nil at an early stage of startup, and when Emacs
Lisp_Object Vautoload_queue;
-/* When lexical binding is being used, this is non-nil, and contains an
- alist of lexically-bound variable, or (t), indicating an empty
- environment. The lisp name of this variable is
- `internal-interpreter-environment'. Every element of this list
- can be either a cons (VAR . VAL) specifying a lexical binding,
- or a single symbol VAR indicating that this variable should use
- dynamic scoping. */
-
-Lisp_Object Vinternal_interpreter_environment;
-
/* Current number of specbindings allocated in specpdl. */
EMACS_INT specpdl_size;
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);
+INFUN (Ffetch_bytecode, 1);
\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;
return val;
}
-DEFUN ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
+DEFUE ("progn", Fprogn, Sprogn, 0, UNEVALLED, 0,
doc: /* Eval BODY forms sequentially and return value of last one.
usage: (progn BODY...) */)
(Lisp_Object args)
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;
}
-DEFUN ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
+DEFUE ("interactive-p", Finteractive_p, Sinteractive_p, 0, 0, 0,
doc: /* Return t if the containing function was run directly by user input.
This means that the function was called with `call-interactively'
\(which includes being called as the binding of a key)
|| 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;
_longjmp (catch->jmp, 1);
}
-DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
+DEFUE ("throw", Fthrow, Sthrow, 2, 2, 0,
doc: /* Throw to the catch for TAG and return VALUE from it.
Both TAG and VALUE are evalled. */)
(register Lisp_Object tag, Lisp_Object value)
|| (CONSP (tem)
&& (SYMBOLP (XCAR (tem))
|| CONSP (XCAR (tem))))))
- error ("Invalid condition handler", tem);
+ error ("Invalid condition handler");
}
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))
static int maybe_call_debugger (Lisp_Object conditions, Lisp_Object sig,
Lisp_Object data);
-DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
+DEFUE ("signal", Fsignal, Ssignal, 2, 2, 0,
doc: /* Signal an error. Args are ERROR-SYMBOL and associated DATA.
This function does not return.
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, min (INT_MAX, SIZE_MAX - 1)) + 1;
char *buffer = buf;
- int allocated = 0;
+ int used;
Lisp_Object string;
- mlen = strlen (m);
-
while (1)
{
- EMACS_INT used;
- used = doprnt (buffer, size, m, m + mlen, ap);
- if (used < size)
- break;
- size *= 2;
- if (allocated)
- buffer = (char *) xrealloc (buffer, size);
- else
+ used = vsnprintf (buffer, size, m, ap);
+
+ if (used < 0)
{
- buffer = (char *) xmalloc (size);
- allocated = 1;
+ /* Non-C99 vsnprintf, such as w32, returns -1 when SIZE is too small.
+ Guess a larger USED to work around the incompatibility. */
+ used = (size <= size_max / 2 ? 2 * size
+ : size < size_max ? size_max - 1
+ : size_max);
}
+ else if (used < size)
+ break;
+ if (size_max <= used)
+ memory_full ();
+ size = used + 1;
+
+ 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
va_end (ap);
}
\f
-DEFUN ("commandp", Fcommandp, Scommandp, 1, 2, 0,
+DEFUE ("commandp", Fcommandp, Scommandp, 1, 2, 0,
doc: /* Non-nil if FUNCTION makes provisions for interactive calling.
This means it contains a description for how to read arguments to give it.
The value is nil for an invalid function or a symbol with no function
if (!CONSP (fun))
return Qnil;
funcar = XCAR (fun);
- if (EQ (funcar, Qlambda))
+ if (EQ (funcar, Qclosure))
+ 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;
- if (EQ (funcar, Qautoload))
+ else if (EQ (funcar, Qautoload))
return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
else
return Qnil;
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)))
}
\f
-DEFUN ("eval", Feval, Seval, 1, 2, 0,
+DEFUE ("eval", Feval, Seval, 1, 2, 0,
doc: /* Evaluate FORM and return its value.
If LEXICAL is t, evaluate using lexical scoping. */)
(Lisp_Object form, Lisp_Object lexical)
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));
}
}
}
- else if (FUNVECP (fun))
+ else if (COMPILEDP (fun))
val = apply_lambda (fun, original_args);
else
{
return val;
}
\f
-DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
+DEFUE ("apply", Fapply, Sapply, 2, MANY, 0,
doc: /* Call FUNCTION with our remaining args, using our last arg as list of args.
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,
+DEFUE ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
doc: /* Run each hook in HOOKS.
Each argument should be a symbol, a hook variable.
These symbols are processed in the order specified.
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;
}
-DEFUN ("run-hook-with-args", Frun_hook_with_args,
+DEFUE ("run-hook-with-args", Frun_hook_with_args,
Srun_hook_with_args, 1, MANY, 0,
doc: /* Run HOOK with the specified arguments ARGS.
HOOK should be a symbol, a hook variable. If HOOK has a non-nil
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,
+DEFUE ("run-hook-with-args-until-failure", Frun_hook_with_args_until_failure,
Srun_hook_with_args_until_failure, 1, MANY, 0,
doc: /* Run HOOK with the specified arguments ARGS.
HOOK should be a symbol, a hook variable. If HOOK has a non-nil
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)
{
- return run_hook_with_args (nargs, args, until_failure);
+ 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, 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. */)
+DEFUE ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
+ 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))
{
if (SUBRP (object))
return (XSUBR (object)->max_args != UNEVALLED) ? Qt : Qnil;
- else if (FUNVECP (object))
+ else if (COMPILEDP (object))
return Qt;
else if (CONSP (object))
{
return Qnil;
}
-DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
+DEFUE ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
doc: /* Call first argument as a function, passing remaining arguments to it.
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
}
}
}
- else if (FUNVECP (fun))
+ else if (COMPILEDP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
{
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)
return tem;
}
-
-/* Call a non-bytecode funvec object FUN, on the argments in ARGS (of
- length NARGS). */
-
-static Lisp_Object
-funcall_funvec (Lisp_Object fun, int nargs, Lisp_Object *args)
-{
- int size = FUNVEC_SIZE (fun);
- Lisp_Object tag = (size > 0 ? AREF (fun, 0) : Qnil);
-
- if (EQ (tag, Qcurry))
- {
- /* A curried function is a way to attach arguments to a another
- function. The first element of the vector is the identifier
- `curry', the second is the wrapped function, and remaining
- elements are the attached arguments. */
- int num_curried_args = size - 2;
- /* Offset of the curried and user args in the final arglist. Curried
- args are first in the new arg vector, after the function. User
- args follow. */
- int curried_args_offs = 1;
- int user_args_offs = curried_args_offs + num_curried_args;
- /* The curried function and arguments. */
- Lisp_Object *curry_params = XVECTOR (fun)->contents + 1;
- /* The arguments in the curry vector. */
- Lisp_Object *curried_args = curry_params + 1;
- /* The number of arguments with which we'll call funcall, and the
- arguments themselves. */
- int num_funcall_args = 1 + num_curried_args + nargs;
- Lisp_Object *funcall_args
- = (Lisp_Object *) alloca (num_funcall_args * sizeof (Lisp_Object));
-
- /* First comes the real function. */
- funcall_args[0] = curry_params[0];
-
- /* Then the arguments in the appropriate order. */
- memcpy (funcall_args + curried_args_offs, curried_args,
- num_curried_args * sizeof (Lisp_Object));
- memcpy (funcall_args + user_args_offs, args,
- nargs * sizeof (Lisp_Object));
-
- return Ffuncall (num_funcall_args, funcall_args);
- }
- else
- xsignal1 (Qinvalid_function, fun);
-}
-
-
/* Apply a Lisp function FUN to the NARGS evaluated arguments in ARG_VECTOR
and return the result of evaluation.
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;
-
- if (COMPILEDP (fun)
- && FUNVEC_SIZE (fun) > COMPILED_PUSH_ARGS
- && ! NILP (XVECTOR (fun)->contents[COMPILED_PUSH_ARGS]))
- /* A byte-code object with a non-nil `push args' slot means we
- shouldn't bind any arguments, instead just call the byte-code
- interpreter directly; it will push arguments as necessary.
-
- Byte-code objects with either a non-existant, or a nil value for
- the `push args' slot (the default), have dynamically-bound
- arguments, and use the argument-binding code below instead (as do
- all interpreted functions, even lexically bound ones). */
- {
- /* If we have not actually read the bytecode string
- and constants vector yet, fetch them from the file. */
- if (CONSP (AREF (fun, COMPILED_BYTECODE)))
- Ffetch_bytecode (fun);
- return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
- AREF (fun, COMPILED_CONSTANTS),
- AREF (fun, COMPILED_STACK_DEPTH),
- AREF (fun, COMPILED_ARGLIST),
- nargs, arg_vector);
- }
-
- if (FUNVECP (fun) && !FUNVEC_COMPILED_P (fun))
- /* Byte-compiled functions are handled directly below, but we
- call other funvec types via funcall_funvec. */
- return funcall_funvec (fun, nargs, arg_vector);
+ 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;
else if (COMPILEDP (fun))
{
syms_left = AREF (fun, COMPILED_ARGLIST);
+ if (INTEGERP (syms_left))
+ /* A byte-code object with a non-nil `push args' slot means we
+ shouldn't bind any arguments, instead just call the byte-code
+ interpreter directly; it will push arguments as necessary.
+
+ Byte-code objects with either a non-existant, or a nil value for
+ the `push args' slot (the default), have dynamically-bound
+ arguments, and use the argument-binding code below instead (as do
+ all interpreted functions, even lexically bound ones). */
+ {
+ /* If we have not actually read the bytecode string
+ and constants vector yet, fetch them from the file. */
+ if (CONSP (AREF (fun, COMPILED_BYTECODE)))
+ Ffetch_bytecode (fun);
+ return exec_byte_code (AREF (fun, COMPILED_BYTECODE),
+ AREF (fun, COMPILED_CONSTANTS),
+ AREF (fun, COMPILED_STACK_DEPTH),
+ syms_left,
+ nargs, arg_vector);
+ }
lexenv = Qnil;
}
else
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)
- /* FIXME: there's no good reason to allow dynamic-scoping
- on function arguments, other than consistency with let. */
- && !XSYMBOL (next)->declared_special
- && NILP (Fmemq (next, Vinternal_interpreter_environment)))
+ 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 ("curry", Fcurry, Scurry, 1, MANY, 0,
- doc: /* Return FUN curried with ARGS.
-The result is a function-like object that will append any arguments it
-is called with to ARGS, and call FUN with the resulting list of arguments.
-
-For instance:
- (funcall (curry '+ 3 4 5) 2) is the same as (funcall '+ 3 4 5 2)
-and:
- (mapcar (curry 'concat "The ") '("a" "b" "c"))
- => ("The a" "The b" "The c")
-
-usage: (curry FUN &rest ARGS) */)
- (int nargs, Lisp_Object *args)
-{
- return make_funvec (Qcurry, 0, nargs, args);
-}
-\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);
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]);
}
}
Qclosure = intern_c_string ("closure");
staticpro (&Qclosure);
- Qcurry = intern_c_string ("curry");
- staticpro (&Qcurry);
-
Qdebug = intern_c_string ("debug");
staticpro (&Qdebug);
The value the function returns is not used. */);
Vmacro_declaration_function = Qnil;
+ /* When lexical binding is being used,
+ vinternal_interpreter_environment is non-nil, and contains an alist
+ of lexically-bound variable, or (t), indicating an empty
+ environment. The lisp name of this variable would be
+ `internal-interpreter-environment' if it weren't hidden.
+ Every element of this list can be either a cons (VAR . VAL)
+ specifying a lexical binding, or a single symbol VAR indicating
+ that this variable should use dynamic scoping. */
Qinternal_interpreter_environment
= intern_c_string ("internal-interpreter-environment");
staticpro (&Qinternal_interpreter_environment);
-#if 0 /* Don't export this variable to Elisp, so noone can mess with it
- (Just imagine if someone makes it buffer-local). */
- DEFVAR__LISP ("internal-interpreter-environment",
- Vinternal_interpreter_environment,
+ DEFVAR_LISP ("internal-interpreter-environment",
+ Vinternal_interpreter_environment,
doc: /* If non-nil, the current lexical environment of the lisp interpreter.
When lexical binding is not being used, this variable is nil.
A value of `(t)' indicates an empty environment, otherwise it is an
alist of active lexical bindings. */);
-#endif
Vinternal_interpreter_environment = Qnil;
+ /* Don't export this variable to Elisp, so noone can mess with it
+ (Just imagine if someone makes it buffer-local). */
+ Funintern (Qinternal_interpreter_environment, Qnil);
Vrun_hooks = intern_c_string ("run-hooks");
staticpro (&Vrun_hooks);
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 (&Scurry);
defsubr (&Sbacktrace_debug);
defsubr (&Sbacktrace);
defsubr (&Sbacktrace_frame);
- defsubr (&Scurry);
defsubr (&Sspecial_variable_p);
defsubr (&Sfunctionp);
}
-
HCoop / bpt / emacs.git / blobdiff