mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-24 07:20:37 +00:00
Code Issues Releases Activity

(cl-labels): Add support for (FUNC EXP) bindings (bug#59786)

Browse Source 
Allow `cl-labels` to use the same (FUNC EXP) bindings as were already added
to `cl-flet` in Emacs-25.  The Info doc (mistakenly) already documented this
new feature.

* lisp/emacs-lisp/cl-macs.el (cl--self-tco-on-form): New function.
(cl-labels): Use it to add support for (FUNC EXP) bindings.

* test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--labels): Add test for
tail-recursive (FUNC EXP) bindings.
This commit is contained in:
Stefan Monnier 2024-11-12 22:58:53 -05:00
parent a7400cb881
commit 79400f4f18
3 changed files with 51 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
etc/NEWS
View File

@ -236,6 +236,11 @@ modal editing packages.
* Changes in Specialized Modes and Packages in Emacs 31.1 * Changes in Specialized Modes and Packages in Emacs 31.1
** CL-Lib
+++
*** 'cl-labels' now also accepts (FUNC EXP) bindings, like 'cl-flet'.
Such bindings make it possible to compute which function to bind to FUNC.
** Whitespace ** Whitespace
--- ---

50
lisp/emacs-lisp/cl-macs.el
View File

@ -2247,15 +2247,35 @@ Like `cl-flet' but the definitions can refer to previous ones.
. ,optimized-body)) . ,optimized-body))
,retvar))))))) ,retvar)))))))
(defun cl--self-tco-on-form (var form)
;; Apply self-tco to the function returned by FORM, assuming that
;; it will be bound to VAR.
(pcase form
(`(function (lambda ,fargs . ,ebody)) form
(pcase-let* ((`(,decls . ,body) (macroexp-parse-body ebody))
(`(,ofargs . ,obody) (cl--self-tco var fargs body)))
`(function (lambda ,ofargs ,@decls . ,obody))))
(`(let ,bindings ,form)
`(let ,bindings ,(cl--self-tco-on-form var form)))
(`(if ,cond ,exp1 ,exp2)
`(if ,cond ,(cl--self-tco-on-form var exp1)
,(cl--self-tco-on-form var exp2)))
(`(oclosure--fix-type ,exp1 ,exp2)
`(oclosure--fix-type ,exp1 ,(cl--self-tco-on-form var exp2)))
(_ form)))
;;;###autoload ;;;###autoload
(defmacro cl-labels (bindings &rest body) (defmacro cl-labels (bindings &rest body)
"Make local (recursive) function definitions. "Make local (recursive) function definitions.
BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where BINDINGS is a list of definitions of the form either (FUNC EXP)
where EXP is a form that should return the function to bind to the
function name FUNC, or (FUNC ARGLIST BODY...) where
FUNC is the function name, ARGLIST its arguments, and BODY the FUNC is the function name, ARGLIST its arguments, and BODY the
forms of the function body. FUNC is defined in any BODY, as well forms of the function body. FUNC is in scope in any BODY or EXP, as well
as FORM, so you can write recursive and mutually recursive as FORM, so you can write recursive and mutually recursive
function definitions. See info node `(cl) Function Bindings' for function definitions, with the caveat that EXPs are evaluated in sequence
details. and you cannot call a FUNC before its EXP has been evaluated.
See info node `(cl) Function Bindings' for details.
\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" \(fn ((FUNC ARGLIST BODY...) ...) FORM...)"
(declare (indent 1) (debug cl-flet)) (declare (indent 1) (debug cl-flet))
@ -2273,18 +2293,16 @@ details.
(unless (assq 'function newenv) (unless (assq 'function newenv)
(push (cons 'function #'cl--labels-convert) newenv)) (push (cons 'function #'cl--labels-convert) newenv))
;; Perform self-tail call elimination. ;; Perform self-tail call elimination.
(setq binds (mapcar `(letrec ,(mapcar
(lambda (bind) (lambda (bind)
(pcase-let* (pcase-let* ((`(,var ,sargs . ,sbody) bind))
((`(,var ,sargs . ,sbody) bind) `(,var ,(cl--self-tco-on-form
(`(function (lambda ,fargs . ,ebody)) var (macroexpand-all
(macroexpand-all `(cl-function (lambda ,sargs . ,sbody)) (if (null sbody)
newenv)) sargs ;A (FUNC EXP) definition.
(`(,ofargs . ,obody) `(cl-function (lambda ,sargs . ,sbody)))
(cl--self-tco var fargs ebody))) newenv)))))
`(,var (function (lambda ,ofargs . ,obody))))) (nreverse binds))
(nreverse binds)))
`(letrec ,binds
. ,(macroexp-unprogn . ,(macroexp-unprogn
(macroexpand-all (macroexpand-all
(macroexp-progn body) (macroexp-progn body)

14
test/lisp/emacs-lisp/cl-macs-tests.el
View File

@ -666,7 +666,15 @@ collection clause."
(len4 (xs n) (len4 (xs n)
(cond (xs (cond (nil 'nevertrue) (cond (xs (cond (nil 'nevertrue)
((len4 (cdr xs) (1+ n))))) ((len4 (cdr xs) (1+ n)))))
(t n)))) (t n)))
;; Tail calls through obstacles.
(len5
(if (not (fboundp 'oclosure-lambda))
#'ignore
(oclosure-lambda (accessor (type 'cl-macs-test) (slot 'length))
(xs n)
(if xs (len5 (cdr xs) (1+ n)) n)))))
(should (equal (len nil 0) 0)) (should (equal (len nil 0) 0))
(should (equal (len2 nil 0) 0)) (should (equal (len2 nil 0) 0))
(should (equal (len3 nil 0) 0)) (should (equal (len3 nil 0) 0))
@ -675,11 +683,13 @@ collection clause."
(should (equal (len2 list-42 0) 42)) (should (equal (len2 list-42 0) 42))
(should (equal (len3 list-42 0) 42)) (should (equal (len3 list-42 0) 42))
(should (equal (len4 list-42 0) 42)) (should (equal (len4 list-42 0) 42))
(should (equal (len5 list-42 0) 42))
;; Should not bump into stack depth limits. ;; Should not bump into stack depth limits.
(should (equal (len list-42k 0) 42000)) (should (equal (len list-42k 0) 42000))
(should (equal (len2 list-42k 0) 42000)) (should (equal (len2 list-42k 0) 42000))
(should (equal (len3 list-42k 0) 42000)) (should (equal (len3 list-42k 0) 42000))
(should (equal (len4 list-42k 0) 42000)))) (should (equal (len4 list-42k 0) 42000))
(should (equal (len5 list-42k 0) 42000))))
;; Check that non-recursive functions are handled more efficiently. ;; Check that non-recursive functions are handled more efficiently.
(should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5)))