/* Evaluator for GNU Emacs Lisp interpreter.
-Copyright (C) 1985-1987, 1993-1995, 1999-2015 Free Software Foundation,
+Copyright (C) 1985-1987, 1993-1995, 1999-2016 Free Software Foundation,
Inc.
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
-the Free Software Foundation, either version 3 of the License, or
-(at your option) any later version.
+the Free Software Foundation, either version 3 of the License, or (at
+your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
/* 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
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 lambda_arity (Lisp_Object);
static Lisp_Object
specpdl_symbol (union specbinding *pdl)
{ /* 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);
+ struct handler *c = push_handler (Qunbound, CATCHER);
eassert (c == &handlerlist_sentinel);
handlerlist_sentinel.nextfree = NULL;
handlerlist_sentinel.next = NULL;
if (CONSP (args))
{
Lisp_Object args_left = args;
+ Lisp_Object numargs = Flength (args);
+
+ if (XINT (numargs) & 1)
+ xsignal2 (Qwrong_number_of_arguments, Qsetq, numargs);
do
{
Warning: `quote' does not construct its return value, but just returns
the value that was pre-constructed by the Lisp reader (see info node
`(elisp)Printed Representation').
-This means that '(a . b) is not identical to (cons 'a 'b): the former
+This means that \\='(a . b) is not identical to (cons \\='a \\='b): the former
does not cons. Quoting should be reserved for constants that will
never be modified by side-effects, unless you like self-modifying code.
See the common pitfall in info node `(elisp)Rearrangement' for an example
error ("Cannot make an internal variable an alias");
case SYMBOL_LOCALIZED:
error ("Don't know how to make a localized variable an alias");
+ case SYMBOL_PLAINVAL:
+ case SYMBOL_VARALIAS:
+ break;
+ default:
+ emacs_abort ();
}
/* http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00834.html
if (EQ (specpdl_symbol (pdl), symbol))
binding = pdl;
break;
+
+ case SPECPDL_UNWIND:
+ case SPECPDL_UNWIND_PTR:
+ case SPECPDL_UNWIND_INT:
+ case SPECPDL_UNWIND_VOID:
+ case SPECPDL_BACKTRACE:
+ case SPECPDL_LET_LOCAL:
+ break;
+
+ default:
+ emacs_abort ();
}
}
return binding;
binding. This is usually not what you want. Thus, if you need to
load a file defining variables, with this form or with `defconst' or
`defcustom', you should always load that file _outside_ any bindings
-for these variables. \(`defconst' and `defcustom' behave similarly in
+for these variables. (`defconst' and `defcustom' behave similarly in
this respect.)
The optional argument DOCSTRING is a documentation string for the
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)
+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);
+ struct handler *c = push_handler (tag, CATCHER);
/* Call FUNC. */
if (! sys_setjmp (c->jmp))
{
- Lisp_Object val = (*func) (arg);
+ Lisp_Object val = func (arg);
clobbered_eassert (handlerlist == c);
handlerlist = handlerlist->next;
return val;
if (!NILP (tag))
for (c = handlerlist; c; c = c->next)
{
+ if (c->type == CATCHER_ALL)
+ unwind_to_catch (c, Fcons (tag, value));
if (c->type == CATCHER && EQ (c->tag_or_ch, tag))
unwind_to_catch (c, value);
}
Lisp_Object handlers)
{
Lisp_Object val;
- struct handler *c;
struct handler *oldhandlerlist = handlerlist;
int clausenb = 0;
for (i = 0; i < clausenb; i++)
{
Lisp_Object clause = clauses[i];
- Lisp_Object condition = XCAR (clause);
+ Lisp_Object condition = CONSP (clause) ? XCAR (clause) : Qnil;
if (!CONSP (condition))
condition = Fcons (condition, Qnil);
- PUSH_HANDLER (c, condition, CONDITION_CASE);
+ struct handler *c = push_handler (condition, CONDITION_CASE);
if (sys_setjmp (c->jmp))
{
ptrdiff_t count = SPECPDL_INDEX ();
internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers,
Lisp_Object (*hfun) (Lisp_Object))
{
- Lisp_Object val;
- struct handler *c;
-
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
+ 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);
+ return hfun (val);
+ }
+ else
+ {
+ Lisp_Object val = bfun ();
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return val;
}
-
- val = (*bfun) ();
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
}
/* Like internal_condition_case but call BFUN with ARG as its argument. */
Lisp_Object
internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg,
- Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object))
+ Lisp_Object handlers,
+ Lisp_Object (*hfun) (Lisp_Object))
{
- Lisp_Object val;
- struct handler *c;
-
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
+ 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);
+ return hfun (val);
+ }
+ else
+ {
+ Lisp_Object val = bfun (arg);
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return val;
}
-
- val = (*bfun) (arg);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
}
/* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as
Lisp_Object handlers,
Lisp_Object (*hfun) (Lisp_Object))
{
- Lisp_Object val;
- struct handler *c;
-
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
+ 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);
+ return hfun (val);
+ }
+ else
+ {
+ Lisp_Object val = bfun (arg1, arg2);
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return val;
}
-
- val = (*bfun) (arg1, arg2);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
}
/* Like internal_condition_case but call BFUN with NARGS as first,
ptrdiff_t nargs,
Lisp_Object *args))
{
- Lisp_Object val;
- struct handler *c;
-
- PUSH_HANDLER (c, handlers, CONDITION_CASE);
+ 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, nargs, args);
+ return hfun (val, nargs, args);
}
+ else
+ {
+ Lisp_Object val = bfun (nargs, args);
+ clobbered_eassert (handlerlist == c);
+ handlerlist = handlerlist->next;
+ return val;
+ }
+}
- val = (*bfun) (nargs, args);
- clobbered_eassert (handlerlist == c);
- handlerlist = handlerlist->next;
- return val;
+struct handler *
+push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype)
+{
+ struct handler *c = push_handler_nosignal (tag_ch_val, handlertype);
+ if (!c)
+ memory_full (sizeof *c);
+ return c;
+}
+
+struct handler *
+push_handler_nosignal (Lisp_Object tag_ch_val, enum handlertype handlertype)
+{
+ struct handler *c = handlerlist->nextfree;
+ if (!c)
+ {
+ c = malloc (sizeof *c);
+ if (!c)
+ return c;
+ if (profiler_memory_running)
+ malloc_probe (sizeof *c);
+ c->nextfree = NULL;
+ handlerlist->nextfree = c;
+ }
+ c->type = handlertype;
+ c->tag_or_ch = tag_ch_val;
+ c->val = Qnil;
+ c->next = handlerlist;
+ c->lisp_eval_depth = lisp_eval_depth;
+ c->pdlcount = SPECPDL_INDEX ();
+ c->poll_suppress_count = poll_suppress_count;
+ c->interrupt_input_blocked = interrupt_input_blocked;
+ c->byte_stack = byte_stack_list;
+ handlerlist = c;
+ return c;
}
\f
}
-/* Dump an error message; called like vprintf. */
-void
-verror (const char *m, va_list ap)
+/* Format and return a string; called like vprintf. */
+Lisp_Object
+vformat_string (const char *m, va_list ap)
{
char buf[4000];
ptrdiff_t size = sizeof buf;
if (buffer != buf)
xfree (buffer);
- xsignal1 (Qerror, string);
+ return string;
+}
+
+/* Dump an error message; called like vprintf. */
+void
+verror (const char *m, va_list ap)
+{
+ xsignal1 (Qerror, vformat_string (m, ap));
}
Lisp_Object funcar;
ptrdiff_t count;
+ /* Declare here, as this array may be accessed by call_debugger near
+ the end of this function. See Bug#21245. */
+ Lisp_Object argvals[8];
+
if (SYMBOLP (form))
{
/* Look up its binding in the lexical environment.
if (SUBRP (fun))
{
- Lisp_Object numargs;
- Lisp_Object argvals[8];
- Lisp_Object args_left;
- register int i, maxargs;
-
- args_left = original_args;
- numargs = Flength (args_left);
+ Lisp_Object args_left = original_args;
+ Lisp_Object numargs = Flength (args_left);
check_cons_list ();
set_backtrace_args (specpdl + count, vals, XINT (numargs));
val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals);
+
+ check_cons_list ();
+ 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
{
- maxargs = XSUBR (fun)->max_args;
+ int i, maxargs = XSUBR (fun)->max_args;
+
for (i = 0; i < maxargs; i++)
{
argvals[i] = eval_sub (Fcar (args_left));
}
}
else if (COMPILEDP (fun))
- val = apply_lambda (fun, original_args, count);
+ return apply_lambda (fun, original_args, count);
else
{
if (NILP (fun))
}
else if (EQ (funcar, Qlambda)
|| EQ (funcar, Qclosure))
- val = apply_lambda (fun, original_args, count);
+ return apply_lambda (fun, original_args, count);
else
xsignal1 (Qinvalid_function, original_fun);
}
DEFUN ("apply", Fapply, Sapply, 1, 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.
+Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
usage: (apply FUNCTION &rest ARGUMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
DEFUN ("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).
+Thus, (funcall \\='cons \\='x \\='y) returns (x . y).
usage: (funcall FUNCTION &rest ARGUMENTS) */)
(ptrdiff_t nargs, Lisp_Object *args)
{
set_backtrace_args (specpdl + count, arg_vector, i);
tem = funcall_lambda (fun, numargs, arg_vector);
+ check_cons_list ();
+ lisp_eval_depth--;
/* Do the debug-on-exit now, while arg_vector still exists. */
if (backtrace_debug_on_exit (specpdl + count))
- {
- /* Don't do it again when we return to eval. */
- set_backtrace_debug_on_exit (specpdl + count, false);
- tem = call_debugger (list2 (Qexit, tem));
- }
+ tem = call_debugger (list2 (Qexit, tem));
SAFE_FREE ();
+ specpdl_ptr--;
return tem;
}
}
else if (COMPILEDP (fun))
{
+ ptrdiff_t size = ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK;
+ if (size <= COMPILED_STACK_DEPTH)
+ xsignal1 (Qinvalid_function, fun);
syms_left = AREF (fun, COMPILED_ARGLIST);
if (INTEGERP (syms_left))
/* A byte-code object with a non-nil `push args' slot means we
return unbind_to (count, val);
}
+DEFUN ("func-arity", Ffunc_arity, Sfunc_arity, 1, 1, 0,
+ doc: /* Return minimum and maximum number of args allowed for FUNCTION.
+FUNCTION must be a function of some kind.
+The returned value is a cons cell (MIN . MAX). MIN is the minimum number
+of args. MAX is the maximum number, or the symbol `many', for a
+function with `&rest' args, or `unevalled' for a special form. */)
+ (Lisp_Object function)
+{
+ Lisp_Object original;
+ Lisp_Object funcar;
+ Lisp_Object result;
+
+ original = function;
+
+ retry:
+
+ /* Optimize for no indirection. */
+ function = original;
+ if (SYMBOLP (function) && !NILP (function))
+ {
+ function = XSYMBOL (function)->function;
+ if (SYMBOLP (function))
+ function = indirect_function (function);
+ }
+
+ if (CONSP (function) && EQ (XCAR (function), Qmacro))
+ function = XCDR (function);
+
+ if (SUBRP (function))
+ result = Fsubr_arity (function);
+ else if (COMPILEDP (function))
+ result = lambda_arity (function);
+ else
+ {
+ if (NILP (function))
+ xsignal1 (Qvoid_function, original);
+ if (!CONSP (function))
+ xsignal1 (Qinvalid_function, original);
+ funcar = XCAR (function);
+ if (!SYMBOLP (funcar))
+ xsignal1 (Qinvalid_function, original);
+ if (EQ (funcar, Qlambda)
+ || EQ (funcar, Qclosure))
+ result = lambda_arity (function);
+ else if (EQ (funcar, Qautoload))
+ {
+ Fautoload_do_load (function, original, Qnil);
+ goto retry;
+ }
+ else
+ xsignal1 (Qinvalid_function, original);
+ }
+ return result;
+}
+
+/* FUN must be either a lambda-expression or a compiled-code object. */
+static Lisp_Object
+lambda_arity (Lisp_Object fun)
+{
+ Lisp_Object syms_left;
+
+ if (CONSP (fun))
+ {
+ if (EQ (XCAR (fun), Qclosure))
+ {
+ fun = XCDR (fun); /* Drop `closure'. */
+ CHECK_LIST_CONS (fun, fun);
+ }
+ syms_left = XCDR (fun);
+ if (CONSP (syms_left))
+ syms_left = XCAR (syms_left);
+ else
+ xsignal1 (Qinvalid_function, fun);
+ }
+ else if (COMPILEDP (fun))
+ {
+ ptrdiff_t size = ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK;
+ if (size <= COMPILED_STACK_DEPTH)
+ xsignal1 (Qinvalid_function, fun);
+ syms_left = AREF (fun, COMPILED_ARGLIST);
+ if (INTEGERP (syms_left))
+ return get_byte_code_arity (syms_left);
+ }
+ else
+ emacs_abort ();
+
+ EMACS_INT minargs = 0, maxargs = 0;
+ bool optional = false;
+ for (; CONSP (syms_left); syms_left = XCDR (syms_left))
+ {
+ Lisp_Object next = XCAR (syms_left);
+ if (!SYMBOLP (next))
+ xsignal1 (Qinvalid_function, fun);
+
+ if (EQ (next, Qand_rest))
+ return Fcons (make_number (minargs), Qmany);
+ else if (EQ (next, Qand_optional))
+ optional = true;
+ else
+ {
+ if (!optional)
+ minargs++;
+ maxargs++;
+ }
+ }
+
+ if (!NILP (syms_left))
+ xsignal1 (Qinvalid_function, fun);
+
+ return Fcons (make_number (minargs), make_number (maxargs));
+}
+
DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
1, 1, 0,
doc: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
{
Lisp_Object tem;
- if (COMPILEDP (object) && CONSP (AREF (object, COMPILED_BYTECODE)))
+ if (COMPILEDP (object))
{
- tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
- if (!CONSP (tem))
+ ptrdiff_t size = ASIZE (object) & PSEUDOVECTOR_SIZE_MASK;
+ if (size <= COMPILED_STACK_DEPTH)
+ xsignal1 (Qinvalid_function, object);
+ if (CONSP (AREF (object, COMPILED_BYTECODE)))
{
- tem = AREF (object, COMPILED_BYTECODE);
- if (CONSP (tem) && STRINGP (XCAR (tem)))
- error ("Invalid byte code in %s", SDATA (XCAR (tem)));
- else
- error ("Invalid byte code");
+ tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
+ if (!CONSP (tem))
+ {
+ tem = AREF (object, COMPILED_BYTECODE);
+ if (CONSP (tem) && STRINGP (XCAR (tem)))
+ error ("Invalid byte code in %s", SDATA (XCAR (tem)));
+ else
+ error ("Invalid byte code");
+ }
+ ASET (object, COMPILED_BYTECODE, XCAR (tem));
+ ASET (object, COMPILED_CONSTANTS, XCDR (tem));
}
- ASET (object, COMPILED_BYTECODE, XCAR (tem));
- ASET (object, COMPILED_CONSTANTS, XCDR (tem));
}
return object;
}
{ /* If variable has a trivial value (no forwarding), we can
just set it. No need to check for constant symbols here,
since that was already done by specbind. */
- struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (specpdl_ptr));
- if (sym->redirect == SYMBOL_PLAINVAL)
+ Lisp_Object sym = specpdl_symbol (specpdl_ptr);
+ if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
{
- SET_SYMBOL_VAL (sym, specpdl_old_value (specpdl_ptr));
+ SET_SYMBOL_VAL (XSYMBOL (sym),
+ specpdl_old_value (specpdl_ptr));
break;
}
else
{ /* If variable has a trivial value (no forwarding), we can
just set it. No need to check for constant symbols here,
since that was already done by specbind. */
- struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (tmp));
- if (sym->redirect == SYMBOL_PLAINVAL)
+ Lisp_Object sym = specpdl_symbol (tmp);
+ if (SYMBOLP (sym) && XSYMBOL (sym)->redirect == SYMBOL_PLAINVAL)
{
Lisp_Object old_value = specpdl_old_value (tmp);
- set_specpdl_old_value (tmp, SYMBOL_VAL (sym));
- SET_SYMBOL_VAL (sym, old_value);
+ set_specpdl_old_value (tmp, SYMBOL_VAL (XSYMBOL (sym)));
+ SET_SYMBOL_VAL (XSYMBOL (sym), old_value);
break;
}
else
else
result = Fcons (Fcons (sym, val), result);
}
+ break;
+
+ case SPECPDL_UNWIND:
+ case SPECPDL_UNWIND_PTR:
+ case SPECPDL_UNWIND_INT:
+ case SPECPDL_UNWIND_VOID:
+ case SPECPDL_BACKTRACE:
+ break;
+
+ default:
+ emacs_abort ();
}
}
}
mark_object (specpdl_symbol (pdl));
mark_object (specpdl_old_value (pdl));
break;
+
+ case SPECPDL_UNWIND_PTR:
+ case SPECPDL_UNWIND_INT:
+ case SPECPDL_UNWIND_VOID:
+ break;
+
+ default:
+ emacs_abort ();
}
}
}
before making `inhibit-quit' nil. */);
Vinhibit_quit = Qnil;
+ DEFSYM (Qsetq, "setq");
DEFSYM (Qinhibit_quit, "inhibit-quit");
DEFSYM (Qautoload, "autoload");
DEFSYM (Qinhibit_debugger, "inhibit-debugger");
defsubr (&Seval);
defsubr (&Sapply);
defsubr (&Sfuncall);
+ defsubr (&Sfunc_arity);
defsubr (&Srun_hooks);
defsubr (&Srun_hook_with_args);
defsubr (&Srun_hook_with_args_until_success);