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

@@ -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:
 

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

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
 

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))))
 

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.

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.  */

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;
 

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))))
 

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"))

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