(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 133105e8a6c842d263da997745fea918dea85c00..ba2183f53b7e937f4a66c02d2f16f73daae74460 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -182,6 +182,11 @@ modal editing packages.
 \f
 * 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 b37f744b1754346bf6c3ace6b690b28873213f95..65bc2cb9173a090fc632a38bc7050cbeee4f8230 100644 (file)
--- 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 3fabcbc50c913443521a0f82c4289d8f54d4ae51..4baf5428101826b53d6b774993110963003e4707 100644 (file)
--- 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)))