master db3fea2e5ce: Detect and prevent function alias loops in `fset` and `defalias`

[Mattias Engdegård]

branch: master
commit db3fea2e5ce46229ae40aa9ca6a89964261a7a5a
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Detect and prevent function alias loops in `fset` and `defalias`
    
    Make `fset` and `defalias` signal an error on attempts to create
    circular alias chains.  This is more effective, efficient and
    convenient than permitting alias loops to be created and trying to
    detect them at run time each time a function is called, which is what
    we have been doing until now, badly.
    
    * lisp/help-fns.el (help-fns--analyze-function):
    Don't pass obsolete argument.
    * lisp/subr.el (function-alias-p):
    * src/data.c (indirect_function, Findirect_function): Simplify.
    Now error-free, second argument obsolete.
    (Ffset): Detect loops.
    * test/lisp/help-fns-tests.el (help-fns--analyze-function-recursive):
    * test/lisp/subr-tests.el (test-alias-p):
    Adapt tests.
    * test/src/data-tests.el (data-tests-fset, data-tests-defalias): New.
    * doc/lispref/eval.texi (Function Indirection):
    * doc/lispref/functions.texi (Defining Functions, Function Cells):
    Update manual.
    * etc/NEWS: Announce.
---
 doc/lispref/eval.texi       | 17 +++++-------
 doc/lispref/functions.texi  | 13 +++++++---
 etc/NEWS                    | 15 +++++++++++
 lisp/help-fns.el            |  2 +-
 lisp/subr.el                | 30 +++++++--------------
 src/data.c                  | 63 ++++++++++++++-------------------------------
 src/eval.c                  |  2 +-
 test/lisp/help-fns-tests.el |  4 ---
 test/lisp/subr-tests.el     | 10 ++++---
 test/src/data-tests.el      | 36 ++++++++++++++++++++++++++
 10 files changed, 103 insertions(+), 89 deletions(-)

diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi
index 88e899de1e8..a45517287b7 100644
--- a/doc/lispref/eval.texi
+++ b/doc/lispref/eval.texi
@@ -252,11 +252,8 @@ the original symbol.  If the contents are another symbol, 
this
 process, called @dfn{symbol function indirection}, is repeated until
 it obtains a non-symbol.  @xref{Function Names}, for more information
 about symbol function indirection.
-
-  One possible consequence of this process is an infinite loop, in the
-event that a symbol's function cell refers to the same symbol.
-Otherwise, we eventually obtain a non-symbol, which ought to be a
-function or other suitable object.
+We eventually obtain a non-symbol, which ought to be a function or
+other suitable object.
 
 @kindex invalid-function
   More precisely, we should now have a Lisp function (a lambda
@@ -332,19 +329,17 @@ or just
   The built-in function @code{indirect-function} provides an easy way to
 perform symbol function indirection explicitly.
 
-@defun indirect-function function &optional noerror
+@defun indirect-function function
 @anchor{Definition of indirect-function}
 This function returns the meaning of @var{function} as a function.  If
 @var{function} is a symbol, then it finds @var{function}'s function
 definition and starts over with that value.  If @var{function} is not a
 symbol, then it returns @var{function} itself.
 
-This function returns @code{nil} if the final symbol is unbound.  It
-signals a @code{cyclic-function-indirection} error if there is a loop
-in the chain of symbols.
+This function returns @code{nil} if the final symbol is unbound.
 
-The optional argument @var{noerror} is obsolete, kept for backward
-compatibility, and has no effect.
+There is also a second, optional argument that is obsolete and has no
+effect.
 
 Here is how you could define @code{indirect-function} in Lisp:
 
diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index f5572e447d3..b6a4ee13308 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -737,9 +737,12 @@ explicitly in the source file being loaded.  This is 
because
 By contrast, in programs that manipulate function definitions for other
 purposes, it is better to use @code{fset}, which does not keep such
 records.  @xref{Function Cells}.
+
+If the resulting function definition chain would be circular, then
+Emacs will signal a @code{cyclic-function-indirection} error.
 @end defun
 
-@defun function-alias-p object &optional noerror
+@defun function-alias-p object
 Checks whether @var{object} is a function alias.  If it is, it returns
 a list of symbols representing the function alias chain, else
 @code{nil}.  For instance, if @code{a} is an alias for @code{b}, and
@@ -750,9 +753,8 @@ a list of symbols representing the function alias chain, 
else
     @result{} (b c)
 @end example
 
-If there's a loop in the definitions, an error will be signaled.  If
-@var{noerror} is non-@code{nil}, the non-looping parts of the chain is
-returned instead.
+There is also a second, optional argument that is obsolete and has no
+effect.
 @end defun
 
   You cannot create a new primitive function with @code{defun} or
@@ -1539,6 +1541,9 @@ is not a function, e.g., a keyboard macro 
(@pxref{Keyboard Macros}):
 If you wish to use @code{fset} to make an alternate name for a
 function, consider using @code{defalias} instead.  @xref{Definition of
 defalias}.
+
+If the resulting function definition chain would be circular, then
+Emacs will signal a @code{cyclic-function-indirection} error.
 @end defun
 
 @node Closures
diff --git a/etc/NEWS b/etc/NEWS
index bcce416ebc1..4b0e4e6bd46 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -327,6 +327,21 @@ This function is like 'user-uid', but is aware of file 
name handlers,
 so it will return the remote UID for remote files (or -1 if the
 connection has no associated user).
 
++++
+** 'fset' and 'defalias' now signal an error for circular alias chains.
+Previously, 'fset' and 'defalias' could be made to build circular
+function indirection chains as in
+
+    (defalias 'able 'baker)
+    (defalias 'baker 'able)
+
+but trying to call them would often make Emacs hang.  Now, an attempt
+to create such a loop results in an error.
+
+Since circular alias chains now cannot occur, 'function-alias-p' and
+'indirect-function' will never signal an error.  Their second
+'noerror' arguments have no effect and are therefore obsolete.
+
 
 * Changes in Emacs 30.1 on Non-Free Operating Systems
 
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 8bf8af73d30..1172f068934 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -996,7 +996,7 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED 
REAL-DEF)."
                                               (symbol-name function)))))))
         (real-def (cond
                     ((and aliased (not (subrp def)))
-                     (car (function-alias-p real-function t)))
+                     (car (function-alias-p real-function)))
                    ((subrp def) (intern (subr-name def)))
                     (t def))))
 
diff --git a/lisp/subr.el b/lisp/subr.el
index 1a4ecc08931..916b6de494b 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -7002,27 +7002,17 @@ string will be displayed only if BODY takes longer than 
TIMEOUT seconds.
                                  (lambda ()
                                    ,@body)))
 
-(defun function-alias-p (func &optional noerror)
+(defun function-alias-p (func &optional _noerror)
   "Return nil if FUNC is not a function alias.
-If FUNC is a function alias, return the function alias chain.
-
-If the function alias chain contains loops, an error will be
-signaled.  If NOERROR, the non-loop parts of the chain is returned."
-  (declare (side-effect-free t))
-  (let ((chain nil)
-        (orig-func func))
-    (nreverse
-     (catch 'loop
-       (while (and (symbolp func)
-                   (setq func (symbol-function func))
-                   (symbolp func))
-         (when (or (memq func chain)
-                   (eq func orig-func))
-           (if noerror
-               (throw 'loop chain)
-             (signal 'cyclic-function-indirection (list orig-func))))
-         (push func chain))
-       chain))))
+If FUNC is a function alias, return the function alias chain."
+  (declare (advertised-calling-convention (func) "30.1")
+           (side-effect-free error-free))
+  (let ((chain nil))
+    (while (and (symbolp func)
+                (setq func (symbol-function func))
+                (symbolp func))
+      (push func chain))
+    (nreverse chain)))
 
 (defun readablep (object)
   "Say whether OBJECT has a readable syntax.
diff --git a/src/data.c b/src/data.c
index 1fa8b0358b5..d2f4d40d7bc 100644
--- a/src/data.c
+++ b/src/data.c
@@ -840,7 +840,9 @@ the position will be taken.  */)
 }
 
 DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
-       doc: /* Set SYMBOL's function definition to DEFINITION, and return 
DEFINITION.  */)
+       doc: /* Set SYMBOL's function definition to DEFINITION, and return 
DEFINITION.
+If the resulting chain of function definitions would contain a loop,
+signal a `cyclic-function-indirection' error.  */)
   (register Lisp_Object symbol, Lisp_Object definition)
 {
   CHECK_SYMBOL (symbol);
@@ -852,6 +854,12 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
 
   eassert (valid_lisp_object_p (definition));
 
+  /* Ensure non-circularity.  */
+  for (Lisp_Object s = definition; SYMBOLP (s) && !NILP (s);
+       s = XSYMBOL (s)->u.s.function)
+    if (EQ (s, symbol))
+      xsignal1 (Qcyclic_function_indirection, symbol);
+
 #ifdef HAVE_NATIVE_COMP
   register Lisp_Object function = XSYMBOL (symbol)->u.s.function;
 
@@ -1078,7 +1086,7 @@ If CMD is not a command, the return value is nil.
 Value, if non-nil, is a list (interactive SPEC).  */)
   (Lisp_Object cmd)
 {
-  Lisp_Object fun = indirect_function (cmd); /* Check cycles.  */
+  Lisp_Object fun = indirect_function (cmd);
   bool genfun = false;
 
   if (NILP (fun))
@@ -1168,7 +1176,7 @@ If COMMAND is not a command, the return value is nil.
 The value, if non-nil, is a list of mode name symbols.  */)
   (Lisp_Object command)
 {
-  Lisp_Object fun = indirect_function (command); /* Check cycles.  */
+  Lisp_Object fun = indirect_function (command);
 
   if (NILP (fun))
     return Qnil;
@@ -2482,55 +2490,22 @@ If the current binding is global (the default), the 
value is nil.  */)
 
 /* If OBJECT is a symbol, find the end of its function chain and
    return the value found there.  If OBJECT is not a symbol, just
-   return it.  If there is a cycle in the function chain, signal a
-   cyclic-function-indirection error.
-
-   This is like Findirect_function, except that it doesn't signal an
-   error if the chain ends up unbound.  */
+   return it.  */
 Lisp_Object
-indirect_function (register Lisp_Object object)
+indirect_function (Lisp_Object object)
 {
-  Lisp_Object tortoise, hare;
-
-  hare = tortoise = object;
-
-  for (;;)
-    {
-      if (!SYMBOLP (hare) || NILP (hare))
-       break;
-      hare = XSYMBOL (hare)->u.s.function;
-      if (!SYMBOLP (hare) || NILP (hare))
-       break;
-      hare = XSYMBOL (hare)->u.s.function;
-
-      tortoise = XSYMBOL (tortoise)->u.s.function;
-
-      if (EQ (hare, tortoise))
-       xsignal1 (Qcyclic_function_indirection, object);
-    }
-
-  return hare;
+  while (SYMBOLP (object) && !NILP (object))
+    object = XSYMBOL (object)->u.s.function;
+  return object;
 }
 
 DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 2, 0,
        doc: /* Return the function at the end of OBJECT's function chain.
 If OBJECT is not a symbol, just return it.  Otherwise, follow all
-function indirections to find the final function binding and return it.
-Signal a cyclic-function-indirection error if there is a loop in the
-function chain of symbols.  */)
-  (register Lisp_Object object, Lisp_Object noerror)
+function indirections to find the final function binding and return it.  */)
+  (Lisp_Object object, Lisp_Object noerror)
 {
-  Lisp_Object result;
-
-  /* Optimize for no indirection.  */
-  result = object;
-  if (SYMBOLP (result) && !NILP (result)
-      && (result = XSYMBOL (result)->u.s.function, SYMBOLP (result)))
-    result = indirect_function (result);
-  if (!NILP (result))
-    return result;
-
-  return Qnil;
+  return indirect_function (object);
 }
 
 /* Extract and set vector and string elements.  */
diff --git a/src/eval.c b/src/eval.c
index e377e30c6fb..eb40c953f96 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2116,7 +2116,7 @@ then strings and vectors are not accepted.  */)
 
   fun = function;
 
-  fun = indirect_function (fun); /* Check cycles.  */
+  fun = indirect_function (fun);
   if (NILP (fun))
     return Qnil;
 
diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el
index 4d715cde1d5..243a45ae6d2 100644
--- a/test/lisp/help-fns-tests.el
+++ b/test/lisp/help-fns-tests.el
@@ -180,10 +180,6 @@ Return first line of the output of (describe-function-1 
FUNC)."
 
 (ert-deftest help-fns--analyze-function-recursive ()
   (defalias 'help-fns--a 'help-fns--b)
-  (should (equal (help-fns--analyze-function 'help-fns--a)
-                 '(help-fns--a help-fns--b t help-fns--b)))
-  ;; Make a loop and see that it doesn't infloop.
-  (defalias 'help-fns--b 'help-fns--a)
   (should (equal (help-fns--analyze-function 'help-fns--a)
                  '(help-fns--a help-fns--b t help-fns--b))))
 
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 1abd3be4ea1..d5efabc1370 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -1058,10 +1058,12 @@ final or penultimate step during initialization."))
                  '(subr-tests--b subr-tests--c)))
 
   (defalias 'subr-tests--d 'subr-tests--e)
-  (defalias 'subr-tests--e 'subr-tests--d)
-  (should-error (function-alias-p 'subr-tests--d))
-  (should (equal (function-alias-p 'subr-tests--d t)
-                 '(subr-tests--e))))
+  (should (equal (function-alias-p 'subr-tests--d)
+                 '(subr-tests--e)))
+
+  (fset 'subr-tests--f 'subr-tests--a)
+  (should (equal (function-alias-p 'subr-tests--f)
+                 '(subr-tests--a subr-tests--b subr-tests--c))))
 
 (ert-deftest test-readablep ()
   (should (readablep "foo"))
diff --git a/test/src/data-tests.el b/test/src/data-tests.el
index 28cee9d2c5b..680fdd57d71 100644
--- a/test/src/data-tests.el
+++ b/test/src/data-tests.el
@@ -772,4 +772,40 @@ comparing the subr with a much slower Lisp implementation."
   "Can't set variable marked with 'make_symbol_constant'."
   (should-error (setq most-positive-fixnum 1) :type 'setting-constant))
 
+(ert-deftest data-tests-fset ()
+  (fset 'data-tests--fs-fun (lambda () 'moo))
+  (declare-function data-tests--fs-fun nil)
+  (should (equal (data-tests--fs-fun) 'moo))
+
+  (fset 'data-tests--fs-fun1 'data-tests--fs-fun)
+  (declare-function data-tests--fs-fun1 nil)
+  (should (equal (data-tests--fs-fun1) 'moo))
+
+  (fset 'data-tests--fs-a 'data-tests--fs-b)
+  (fset 'data-tests--fs-b 'data-tests--fs-c)
+
+  (should-error (fset 'data-tests--fs-c 'data-tests--fs-c)
+                :type 'cyclic-function-indirection)
+  (fset 'data-tests--fs-d 'data-tests--fs-a)
+  (should-error (fset 'data-tests--fs-c 'data-tests--fs-d)
+                :type 'cyclic-function-indirection))
+
+(ert-deftest data-tests-defalias ()
+  (defalias 'data-tests--da-fun (lambda () 'baa))
+  (declare-function data-tests--da-fun nil)
+  (should (equal (data-tests--da-fun) 'baa))
+
+  (defalias 'data-tests--da-fun1 'data-tests--da-fun)
+  (declare-function data-tests--da-fun1 nil)
+  (should (equal (data-tests--da-fun1) 'baa))
+
+  (defalias 'data-tests--da-a 'data-tests--da-b)
+  (defalias 'data-tests--da-b 'data-tests--da-c)
+
+  (should-error (defalias 'data-tests--da-c 'data-tests--da-c)
+                :type 'cyclic-function-indirection)
+  (defalias 'data-tests--da-d 'data-tests--da-a)
+  (should-error (defalias 'data-tests--da-c 'data-tests--da-d)
+                :type 'cyclic-function-indirection))
+
 ;;; data-tests.el ends here