/* 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
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)
When a handler handles an error, control returns to the `condition-case'
and it executes the handler's BODY...
with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
-(If VAR is nil, the handler can't access that information.)
+\(If VAR is nil, the handler can't access that information.)
Then the value of the last BODY form is returned from the `condition-case'
expression.
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);
struct handler *c = push_handler (condition, CONDITION_CASE);
}
-/* 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));
}
function in order with arguments ARGS, stopping at the first
one that returns nil, and return nil. Otherwise (if all functions
return non-nil, or if there are no functions to call), return non-nil
-(do not rely on the precise return value in this case).
+\(do not rely on the precise return value in this case).
Do not use `make-local-variable' to make a hook variable buffer-local.
Instead, use `add-hook' and specify t for the LOCAL argument.
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. */)
{ /* 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
defsubr (&Seval);
defsubr (&Sapply);
defsubr (&Sfuncall);
+ defsubr (&Sfunc_arity);
defsubr (&Srun_hooks);
defsubr (&Srun_hook_with_args);
defsubr (&Srun_hook_with_args_until_success);