[Emacs-diffs] master 6f3243d: Implement 'func-arity'

[Eli Zaretskii]

branch: master
commit 6f3243db55e61847784178ea812f28ddf003544a
Author: Paul Pogonyshev <address@hidden>
Commit: Eli Zaretskii <address@hidden>

    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.
---
 doc/lispref/functions.texi |   40 +++++++++++++--
 etc/NEWS                   |    7 +++
 src/bytecode.c             |   18 +++++++
 src/eval.c                 |  111 ++++++++++++++++++++++++++++++++++++++++++++
 src/lisp.h                 |    1 +
 test/src/fns-tests.el      |   11 ++++
 6 files changed, 182 insertions(+), 6 deletions(-)

diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index a2e94c3..ff21abb 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -143,6 +143,37 @@ function, i.e., can be passed to @code{funcall}.  Note that
 and returns @code{nil} for special forms.
 @end defun
 
+  It is also possible to find out how many arguments an arbitrary
+function expects:
+
address@hidden 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 @address@hidden(@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
address@hidden&rest} arguments, or the symbol @code{unevalled} if
address@hidden is a special form.
+
+Note that this function might return inaccurate results in some
+situations, such as the following:
+
address@hidden @minus
address@hidden
+Functions defined using @code{apply-partially} (@pxref{Calling
+Functions, apply-partially}).
+
address@hidden
+Functions that are advised using @code{advice-add} (@pxref{Advising
+Named Functions}).
+
address@hidden
+Functions that determine the argument list dynamically, as part of
+their code.
address@hidden itemize
+
address@hidden defun
+
 @noindent
 Unlike @code{functionp}, the next three functions do @emph{not} treat
 a symbol as its function definition.
@@ -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
address@hidden(@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
address@hidden 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 0bc6130..ce21532 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -182,6 +182,13 @@ a new window when opening man pages when there's already 
one, use
         (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
 of a two character construct, i.e. a comment delimiter or escaped
diff --git a/src/bytecode.c b/src/bytecode.c
index 9ae2e82..4ff15d2 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 74b30e6..64a6655 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 e606ffa..7c8b452 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 8617369..688ff1f 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))))