From: Paul Pogonyshev Date: Sat, 26 Mar 2016 08:19:43 +0000 (+0300) Subject: Implement 'func-arity' X-Git-Tag: emacs-26.0.90~2285 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=6f3243db55e61847784178ea812f28ddf003544a;p=emacs.git Implement 'func-arity' * src/eval.c (Ffunc_arity, lambda_arity): New functions. * src/bytecode.c (get_byte_code_arity): New function. * src/lisp.h (get_byte_code_arity): Add prototype. * doc/lispref/functions.texi (What Is a Function): Document 'func-arity'. * etc/NEWS: Mention 'func-arity'. * test/src/fns-tests.el (fns-tests-func-arity): New test set. --- diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index a2e94c34b62..ff21abba61e 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -141,6 +141,37 @@ This function returns @code{t} if @var{object} is any kind of function, i.e., can be passed to @code{funcall}. Note that @code{functionp} returns @code{t} for symbols that are function names, and returns @code{nil} for special forms. +@end defun + + It is also possible to find out how many arguments an arbitrary +function expects: + +@defun func-arity function +This function provides information about the argument list of the +specified @var{function}. The returned value is a cons cell of the +form @w{@code{(@var{min} . @var{max})}}, where @var{min} is the +minimum number of arguments, and @var{max} is either the maximum +number of arguments, or the symbol @code{many} for functions with +@code{&rest} arguments, or the symbol @code{unevalled} if +@var{function} is a special form. + +Note that this function might return inaccurate results in some +situations, such as the following: + +@itemize @minus +@item +Functions defined using @code{apply-partially} (@pxref{Calling +Functions, apply-partially}). + +@item +Functions that are advised using @code{advice-add} (@pxref{Advising +Named Functions}). + +@item +Functions that determine the argument list dynamically, as part of +their code. +@end itemize + @end defun @noindent @@ -176,12 +207,9 @@ function. For example: @end defun @defun subr-arity subr -This function provides information about the argument list of a -primitive, @var{subr}. The returned value is a pair -@code{(@var{min} . @var{max})}. @var{min} is the minimum number of -args. @var{max} is the maximum number or the symbol @code{many}, for a -function with @code{&rest} arguments, or the symbol @code{unevalled} if -@var{subr} is a special form. +This works like @code{func-arity}, but only for built-in functions and +without symbol indirection. It signals an error for non-built-in +functions. We recommend to use @code{func-arity} instead. @end defun @node Lambda Expressions diff --git a/etc/NEWS b/etc/NEWS index 0bc61308945..ce21532b68d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -181,6 +181,13 @@ a new window when opening man pages when there's already one, use (inhibit-same-window . nil) (mode . Man-mode)))) ++++ +** New function 'func-arity' returns information about the argument list +of an arbitrary function. +This is a generalization of 'subr-arity' for functions that are not +built-in primitives. We recommend using this new function instead of +'subr-arity'. + +++ ** 'parse-partial-sexp' state has a new element. Element 10 is non-nil when the last character scanned might be the first character diff --git a/src/bytecode.c b/src/bytecode.c index 9ae2e820d51..4ff15d2912a 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -1987,6 +1987,24 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, return result; } +/* `args_template' has the same meaning as in exec_byte_code() above. */ +Lisp_Object +get_byte_code_arity (Lisp_Object args_template) +{ + if (INTEGERP (args_template)) + { + ptrdiff_t at = XINT (args_template); + bool rest = (at & 128) != 0; + int mandatory = at & 127; + ptrdiff_t nonrest = at >> 8; + + return Fcons (make_number (mandatory), + rest ? Qmany : make_number (nonrest)); + } + else + error ("Unknown args template!"); +} + void syms_of_bytecode (void) { diff --git a/src/eval.c b/src/eval.c index 74b30e66bce..64a6655684c 100644 --- a/src/eval.c +++ b/src/eval.c @@ -90,6 +90,7 @@ union specbinding *backtrace_top (void) EXTERNALLY_VISIBLE; 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) @@ -2934,6 +2935,115 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, 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; + short minargs, maxargs; + + original = function; + + retry: + + /* Optimize for no indirection. */ + function = original; + if (SYMBOLP (function) && !NILP (function) + && (function = XSYMBOL (function)->function, SYMBOLP (function))) + function = indirect_function (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 val, syms_left, next; + ptrdiff_t minargs, maxargs; + bool optional; + + 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 (); + + minargs = maxargs = optional = 0; + for (; CONSP (syms_left); syms_left = XCDR (syms_left)) + { + 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 = 1; + 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. */) @@ -3808,6 +3918,7 @@ alist of active lexical bindings. */); defsubr (&Seval); defsubr (&Sapply); defsubr (&Sfuncall); + defsubr (&Sfunc_arity); defsubr (&Srun_hooks); defsubr (&Srun_hook_with_args); defsubr (&Srun_hook_with_args_until_success); diff --git a/src/lisp.h b/src/lisp.h index e606ffa0259..7c8b452dd5f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4215,6 +4215,7 @@ extern struct byte_stack *byte_stack_list; extern void relocate_byte_stack (void); extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, ptrdiff_t, Lisp_Object *); +extern Lisp_Object get_byte_code_arity (Lisp_Object); /* Defined in macros.c. */ extern void init_macros (void); diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 861736995f4..688ff1f6bd9 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -208,3 +208,14 @@ (should (string-version-lessp "foo1.25.5.png" "foo1.125.5")) (should (string-version-lessp "2" "1245")) (should (not (string-version-lessp "1245" "2")))) + +(ert-deftest fns-tests-func-arity () + (should (equal (func-arity 'car) '(1 . 1))) + (should (equal (func-arity 'caar) '(1 . 1))) + (should (equal (func-arity 'format) '(1 . many))) + (require 'info) + (should (equal (func-arity 'Info-goto-node) '(1 . 3))) + (should (equal (func-arity (lambda (&rest x))) '(0 . many))) + (should (equal (func-arity (eval (lambda (x &optional y)) nil)) '(1 . 2))) + (should (equal (func-arity (eval (lambda (x &optional y)) t)) '(1 . 2))) + (should (equal (func-arity 'let) '(1 . unevalled))))