From: Stefan Monnier Date: Wed, 13 Nov 2024 03:58:53 +0000 (-0500) Subject: (cl-labels): Add support for (FUNC EXP) bindings (bug#59786) X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=7c00157d1091ec73db4f47ff0def33a84e6b4c6a;p=emacs.git (cl-labels): Add support for (FUNC EXP) bindings (bug#59786) 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. (cherry picked from commit 79400f4f18b80cdde72eda86023e41a81d09a164) --- diff --git a/etc/NEWS b/etc/NEWS index 133105e8a6c..ba2183f53b7 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -182,6 +182,11 @@ modal editing packages. * 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 --- diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b37f744b175..65bc2cb9173 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2247,15 +2247,35 @@ Like `cl-flet' but the definitions can refer to previous ones. . ,optimized-body)) ,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 (defmacro cl-labels (bindings &rest body) "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 -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 -function definitions. See info node `(cl) Function Bindings' for -details. +function definitions, with the caveat that EXPs are evaluated in sequence +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...)" (declare (indent 1) (debug cl-flet)) @@ -2273,18 +2293,16 @@ details. (unless (assq 'function newenv) (push (cons 'function #'cl--labels-convert) newenv)) ;; Perform self-tail call elimination. - (setq binds (mapcar - (lambda (bind) - (pcase-let* - ((`(,var ,sargs . ,sbody) bind) - (`(function (lambda ,fargs . ,ebody)) - (macroexpand-all `(cl-function (lambda ,sargs . ,sbody)) - newenv)) - (`(,ofargs . ,obody) - (cl--self-tco var fargs ebody))) - `(,var (function (lambda ,ofargs . ,obody))))) - (nreverse binds))) - `(letrec ,binds + `(letrec ,(mapcar + (lambda (bind) + (pcase-let* ((`(,var ,sargs . ,sbody) bind)) + `(,var ,(cl--self-tco-on-form + var (macroexpand-all + (if (null sbody) + sargs ;A (FUNC EXP) definition. + `(cl-function (lambda ,sargs . ,sbody))) + newenv))))) + (nreverse binds)) . ,(macroexp-unprogn (macroexpand-all (macroexp-progn body) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 3fabcbc50c9..4baf5428101 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -666,7 +666,15 @@ collection clause." (len4 (xs n) (cond (xs (cond (nil 'nevertrue) ((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 (len2 nil 0) 0)) (should (equal (len3 nil 0) 0)) @@ -675,11 +683,13 @@ collection clause." (should (equal (len2 list-42 0) 42)) (should (equal (len3 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 (equal (len list-42k 0) 42000)) (should (equal (len2 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. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5)))