[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master c8a2af3037 1/3: Add new function function-alias-p
From: |
Lars Ingebrigtsen |
Subject: |
master c8a2af3037 1/3: Add new function function-alias-p |
Date: |
Thu, 13 Jan 2022 03:49:27 -0500 (EST) |
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