From: Mattias Engdegård Date: Mon, 20 Feb 2023 14:23:12 +0000 (+0100) Subject: Detect and prevent function alias loops in `fset` and `defalias` X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=db3fea2e5ce46229ae40aa9ca6a89964261a7a5a;p=emacs.git 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. --- 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