master c8a2af3037 1/3: Add new function function-alias-p

[Lars Ingebrigtsen]

branch: master
commit c8a2af3037c647bf6dd53f53af1b344e284f809b
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Add new function function-alias-p
    
    * doc/lispref/functions.texi (Defining Functions): Document it.
    * lisp/subr.el (function-alias-p): New function (bug#53178).
---
 doc/lispref/functions.texi | 17 +++++++++++++++++
 etc/NEWS                   |  5 +++++
 lisp/subr.el               | 22 ++++++++++++++++++++++
 test/lisp/subr-tests.el    | 17 +++++++++++++++++
 4 files changed, 61 insertions(+)

diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi
index 96fecc8c89..caf8e3444f 100644
--- a/doc/lispref/functions.texi
+++ b/doc/lispref/functions.texi
@@ -667,6 +667,23 @@ which file defined the function, just like @code{defun}
 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}.
+@end defun
+
+@defun function-alias-p object &optional noerror
+Use the @code{function-alias-p} function to check whether an object is
+a function alias.  If it isn't, this predicate will return
+non-@code{nil}.  If it is, the value returned will be a list of symbol
+representing the function alias chain.  For instance, if @code{a} is
+an alias for @code{b}, and @code{b} is an alias for @code{c}:
+
+@example
+(function-alias-p 'a)
+    @result{} (b c)
+@end example
+
+If there's a loop in the definitions, an error will be signalled.  If
+@var{noerror} is non-@code{nil}, the non-looping parts of the chain is
+returned instead.
 @end defun
 
   You cannot create a new primitive function with @code{defun} or
diff --git a/etc/NEWS b/etc/NEWS
index 6df77624a2..0cd4322a5e 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -935,6 +935,11 @@ The input must be encoded text.
 
 * Lisp Changes in Emacs 29.1
 
++++
+** New function 'function-alias-p'.
+This predicate says whether an object is a function alias, and if it
+is, the alias chain is returned.
+
 +++
 ** New variable 'lisp-directory' holds the directory of Emacs's own Lisp files.
 
diff --git a/lisp/subr.el b/lisp/subr.el
index 12a5c2a10b..b0d2ab623b 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -6537,4 +6537,26 @@ string will be displayed only if BODY takes longer than 
TIMEOUT seconds.
                                  (lambda ()
                                    ,@body)))
 
+(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
+signalled.  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)
+             (error "Alias loop for `%s'" orig-func)))
+         (push func chain))
+       chain))))
+
 ;;; subr.el ends here
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 9be7511bdc..512b654535 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -1007,5 +1007,22 @@ final or penultimate step during initialization."))
   (should (equal (ensure-list :foo) '(:foo)))
   (should (equal (ensure-list '(1 2 3)) '(1 2 3))))
 
+(ert-deftest test-alias-p ()
+  (should-not (function-alias-p 1))
+
+  (defun subr-tests--fun ())
+  (should-not (function-alias-p 'subr-tests--fun))
+
+  (defalias 'subr-tests--a 'subr-tests--b)
+  (defalias 'subr-tests--b 'subr-tests--c)
+  (should (equal (function-alias-p 'subr-tests--a)
+                 '(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))))
+
 (provide 'subr-tests)
 ;;; subr-tests.el ends here