bug#59786: Allowing arbitrary expressions in cl-labels

[Stefan Monnier via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 1362 bytes --]

Michael Heerdegen [2023-01-13 14:47:52] wrote:
> Stefan Monnier <monnier@iro.umontreal.ca> writes:
>> The patch below uses this "new new" syntax (and adjusts `cl-flet` to
>> also support this new new syntax).  It still lacks a NEWS entry (as
>> well as updating the CL manual), but before I do that, I'd like to hear
>> what other people think,
>
> I like the idea to implement this kind of feature for `cl-labels'.  It's
> a good change IMO.
>
> I don't like the syntax I think (ugly).  The rest of this answer is
> discussing this detail:
>
> I don't recall all details about the ambiguity of the empty body case,
> so forgive me if I'm missing something.
>
> A binding like (my-fun (var1 var2)) with an empty body would give you
> compiler warnings anyway.  Would this be an alternative to your "="
> style syntax:
>
> To specify a local function with an empty body one would have to use
> local variable names starting with "_":
>
>    (my-fun (_var1 _var2))
>
> If not all variables start with an underscore or not all list members
> are symbols, the binding is interpreted as specifying an expression
> evaluating to the function to bind.  This assumes that "_var" never
> specifies a named function.

I guess you're right.  So we should just use the (FUNC EXP) syntax,
exactly like we already do for `cl-flet`.
The patch below does that.


        Stefan

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: cl-labels.patch --]
[-- Type: text/x-diff, Size: 3779 bytes --]

diff --git a/etc/NEWS b/etc/NEWS
index d1c7303f976..562c9c6bdc3 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -215,6 +215,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 b37f744b175..388281e4b1a 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2250,9 +2250,11 @@ cl--self-tco
 ;;;###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 defined 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.
@@ -2273,18 +2275,21 @@ cl-labels
     (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
+                     ,(if (null sbody)
+                          ;; This is a (FUNC EXP) definition.
+                          (macroexpand-all sargs newenv)
+                        (pcase-let*
+                            ((`(function (lambda ,fargs . ,ebody))
+                              (macroexpand-all
+                               `(cl-function (lambda ,sargs . ,sbody)) newenv))
+                             (`(,ofargs . ,obody)
+                              (cl--self-tco var fargs ebody)))
+                          `(function (lambda ,ofargs . ,obody)))))))
+               (nreverse binds))
        . ,(macroexp-unprogn
            (macroexpand-all
             (macroexp-progn body)
diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el
index 14ff8628fb8..376ccebef98 100644
--- a/test/lisp/emacs-lisp/cl-lib-tests.el
+++ b/test/lisp/emacs-lisp/cl-lib-tests.el
@@ -558,5 +558,14 @@ cl-constantly
   (should (equal (mapcar (cl-constantly 3) '(a b c d))
                  '(3 3 3 3))))
 
+(ert-deftest cl-lib-test-labels ()
+  (should (equal (cl-labels ((even (x) (if (= x 0) t (odd (1- x))))
+                             (odd (x) (if (= x 0) nil (even (1- x)))))
+                   (list (even 42) (odd 42)))
+                 '(t nil)))
+  (should (equal (cl-labels ((even (lambda (x) (if (= x 0) t (odd (1- x)))))
+                             (odd (lambda (x) (if (= x 0) nil (even (1- x))))))
+                   (list (even 42) (odd 42)))
+                 '(t nil))))
 
 ;;; cl-lib-tests.el ends here