GNU bug report logs - #74870
cl-labels and cl-flet don't create named blocks

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 74870 in the body.
You can then email your comments to 74870 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Jan Jouleodov <jouleodov <at> protonmail.com>
To: "bug-gnu-emacs <at> gnu.org" <bug-gnu-emacs <at> gnu.org>
Subject: cl-labels and cl-flet don't create named blocks
Date: Fri, 13 Dec 2024 23:30:41 +0000

[Message part 1 (text/plain, inline)]

In ANSI CL, these should create a named CL:BLOCK, allowing one to do a local return via CL:RETURN-FROM. In Emacs, this is not the case, resulting in an uncaught exception.

[Message part 2 (text/html, inline)]

Message #8 received at 74870 <at> debbugs.gnu.org (full text, mbox):

From: Eli Zaretskii <eliz <at> gnu.org>
To: Jan Jouleodov <jouleodov <at> protonmail.com>,
 Stefan Monnier <monnier <at> iro.umontreal.ca>
Cc: 74870 <at> debbugs.gnu.org
Subject: Re: bug#74870: cl-labels and cl-flet don't create named blocks
Date: Sat, 14 Dec 2024 18:54:34 +0200

> Date: Fri, 13 Dec 2024 23:30:41 +0000
> From:  Jan Jouleodov via "Bug reports for GNU Emacs,
>  the Swiss army knife of text editors" <bug-gnu-emacs <at> gnu.org>
> 
> In ANSI CL, these should create a named CL:BLOCK, allowing one to do a local return via
> CL:RETURN-FROM. In Emacs, this is not the case, resulting in an uncaught exception.

I'm guessing this is a documentation bug, in that this particular
aspect of CL is not emulated by cl-labels.

Stefan, am I right?

Message #11 received at 74870 <at> debbugs.gnu.org (full text, mbox):

From: Stefan Monnier <monnier <at> iro.umontreal.ca>
To: Eli Zaretskii <eliz <at> gnu.org>
Cc: 74870 <at> debbugs.gnu.org, Jan Jouleodov <jouleodov <at> protonmail.com>
Subject: Re: bug#74870: cl-labels and cl-flet don't create named blocks
Date: Mon, 16 Dec 2024 22:23:24 -0500

>> In ANSI CL, these should create a named CL:BLOCK, allowing one to do a local return via
>> CL:RETURN-FROM. In Emacs, this is not the case, resulting in an uncaught exception.
> I'm guessing this is a documentation bug, in that this particular
> aspect of CL is not emulated by cl-labels.
> Stefan, am I right?

Could be.  Or it could be an oversight, maybe dating back to many many
years ago, and that nobody noticed until now.

Whichever was the original reason, now we get to decide whether we keep
the behavior or not.  Following Common Lisp's lead should not introduce any
backward compatibility issue, all it would cost us is a slightly more
costly macroexpansion for those macros.


        Stefan

Message #14 received at 74870 <at> debbugs.gnu.org (full text, mbox):

From: Jan Jouleodov <jouleodov <at> protonmail.com>
To: Stefan Monnier <monnier <at> iro.umontreal.ca>
Cc: Eli Zaretskii <eliz <at> gnu.org>, 74870 <at> debbugs.gnu.org
Subject: Re: bug#74870: cl-labels and cl-flet don't create named blocks
Date: Thu, 19 Dec 2024 00:55:34 +0000

> Whichever was the original reason, now we get to decide whether we keep
> the behavior or not. Following Common Lisp's lead should not introduce any
> backward compatibility issue, all it would cost us is a slightly more
> costly macroexpansion for those macros.
>
>
> Stefan

Is there any reason why one would not want to *always* emulate the CL
behavior in cl-lib? I could only think of a backward compatibility
problem before CL was standardized, but I am not familiar with the time
frame of cl-lib to know if that's really the case.

Message #17 received at 74870 <at> debbugs.gnu.org (full text, mbox):

From: Michael Heerdegen <michael_heerdegen <at> web.de>
To: Eli Zaretskii <eliz <at> gnu.org>
Cc: 74870 <at> debbugs.gnu.org, Stefan Monnier <monnier <at> iro.umontreal.ca>,
 Jan Jouleodov <jouleodov <at> protonmail.com>
Subject: Re: bug#74870: cl-labels and cl-flet don't create named blocks
Date: Thu, 19 Dec 2024 17:28:39 +0100

Eli Zaretskii <eliz <at> gnu.org> writes:

> I'm guessing this is a documentation bug, in that this particular
> aspect of CL is not emulated by cl-labels.

I dug a bit into the history.

`flet's implementation indeed lost its implicit `cl-block' in

  de7e2b36875 Get rid of cl-lexical-let, keeping only lexical-let for
  compatibility.
  Stefan Monnier <monnier <at> iro.umontreal.ca>, Thu Jun 7 2012

probably by accident.

OTOH it looks like `cl-labels' never created implicit blocks.  As the
manual describes it as especially useful for recursive local function
bindings, this case is maybe also a bit different.


Michael.

Message #20 received at 74870 <at> debbugs.gnu.org (full text, mbox):

From: Stefan Monnier <monnier <at> iro.umontreal.ca>
To: Jan Jouleodov <jouleodov <at> protonmail.com>
Cc: Eli Zaretskii <eliz <at> gnu.org>, 74870 <at> debbugs.gnu.org
Subject: Re: bug#74870: cl-labels and cl-flet don't create named blocks
Date: Sat, 21 Dec 2024 10:44:04 -0500

> Is there any reason why one would not want to *always* emulate the CL
> behavior in cl-lib? I could only think of a backward compatibility
> problem before CL was standardized, but I am not familiar with the time
> frame of cl-lib to know if that's really the case.

Could you try the patch below?


        Stefan


diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 65bc2cb9173..73741417383 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2096,15 +2096,22 @@ cl-flet
                    cl-declarations body)))
   (let ((binds ()) (newenv macroexpand-all-environment))
     (dolist (binding bindings)
-      (let ((var (make-symbol (format "--cl-%s--" (car binding))))
-            (args-and-body (cdr binding)))
-        (if (and (= (length args-and-body) 1)
-                 (macroexp-copyable-p (car args-and-body)))
+      (let* ((var (make-symbol (format "--cl-%s--" (car binding))))
+             (args-and-body (cdr binding))
+             (args (car args-and-body))
+             (body (cdr args-and-body)))
+        (if (and (null body)
+                 (macroexp-copyable-p args))
             ;; Optimize (cl-flet ((fun var)) body).
-            (setq var (car args-and-body))
-          (push (list var (if (= (length args-and-body) 1)
-                              (car args-and-body)
-                            `(cl-function (lambda . ,args-and-body))))
+            (setq var args)
+          (push (list var (if (null body)
+                              args
+                            (let ((parsed-body (macroexp-parse-body body)))
+                              `(cl-function
+                                (lambda ,args
+                                  ,@(car parsed-body)
+                                  (cl-block ,(car binding)
+                                    ,@(cdr parsed-body)))))))
                 binds))
 	(push (cons (car binding)
                     (lambda (&rest args)
@@ -2300,7 +2307,13 @@ cl-labels
                             var (macroexpand-all
                                  (if (null sbody)
                                      sargs ;A (FUNC EXP) definition.
-                                   `(cl-function (lambda ,sargs . ,sbody)))
+                                   (let ((parsed-body
+                                          (macroexp-parse-body sbody)))
+                                     `(cl-function
+                                       (lambda ,sargs
+                                         ,@(car parsed-body)
+                                         (cl-block ,var
+                                           ,@(cdr parsed-body))))))
                                  newenv)))))
                (nreverse binds))
        . ,(macroexp-unprogn

Message #23 received at 74870 <at> debbugs.gnu.org (full text, mbox):

From: Stefan Monnier <monnier <at> iro.umontreal.ca>
To: Jan Jouleodov <jouleodov <at> protonmail.com>
Cc: Eli Zaretskii <eliz <at> gnu.org>, 74870 <at> debbugs.gnu.org
Subject: Re: bug#74870: cl-labels and cl-flet don't create named blocks
Date: Sat, 21 Dec 2024 11:14:54 -0500

[Message part 1 (text/plain, inline)]

>> Is there any reason why one would not want to *always* emulate the CL
>> behavior in cl-lib? I could only think of a backward compatibility
>> problem before CL was standardized, but I am not familiar with the time
>> frame of cl-lib to know if that's really the case.
> Could you try the patch below?

Never mind, it here's a better one I just pushed to `master`.


        Stefan

[cl-labels.patch (text/x-diff, inline)]

commit 476426168106dbcee67d8ea667e11ebe80c7aaed
Author: Stefan Monnier <monnier <at> iro.umontreal.ca>
Date:   Sat Dec 21 11:13:07 2024 -0500

    (cl-flet, cl-labels): Fix bug#74870
    
    * lisp/emacs-lisp/cl-macs.el (cl-flet, cl-labels): Wrap function
    bodies in `cl-block`.
    
    * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--test-flet-block): New test.

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 65bc2cb9173..b1c42a23acd 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2071,7 +2071,8 @@ cl-flet
 FUNC is the function name, and EXP is an expression that returns the
 function value to which it should be bound, or it can take the more common
 form (FUNC ARGLIST BODY...) which is a shorthand
-for (FUNC (lambda ARGLIST BODY)).
+for (FUNC (lambda ARGLIST BODY)) where BODY is wrapped in
+a `cl-block' named FUNC.
 
 FUNC is defined only within FORM, not BODY, so you can't write
 recursive function definitions.  Use `cl-labels' for that.  See
@@ -2096,15 +2097,22 @@ cl-flet
                    cl-declarations body)))
   (let ((binds ()) (newenv macroexpand-all-environment))
     (dolist (binding bindings)
-      (let ((var (make-symbol (format "--cl-%s--" (car binding))))
-            (args-and-body (cdr binding)))
-        (if (and (= (length args-and-body) 1)
-                 (macroexp-copyable-p (car args-and-body)))
+      (let* ((var (make-symbol (format "--cl-%s--" (car binding))))
+             (args-and-body (cdr binding))
+             (args (car args-and-body))
+             (body (cdr args-and-body)))
+        (if (and (null body)
+                 (macroexp-copyable-p args))
             ;; Optimize (cl-flet ((fun var)) body).
-            (setq var (car args-and-body))
-          (push (list var (if (= (length args-and-body) 1)
-                              (car args-and-body)
-                            `(cl-function (lambda . ,args-and-body))))
+            (setq var args)
+          (push (list var (if (null body)
+                              args
+                            (let ((parsed-body (macroexp-parse-body body)))
+                              `(cl-function
+                                (lambda ,args
+                                  ,@(car parsed-body)
+                                  (cl-block ,(car binding)
+                                    ,@(cdr parsed-body)))))))
                 binds))
 	(push (cons (car binding)
                     (lambda (&rest args)
@@ -2271,10 +2279,11 @@ cl-labels
 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 in scope in any BODY or EXP, as well
-as FORM, so you can write recursive and mutually recursive
-function definitions, with the caveat that EXPs are evaluated in sequence
-and you cannot call a FUNC before its EXP has been evaluated.
+forms of the function body.  BODY is wrapped in a `cl-block' named FUNC.
+FUNC is in scope in any BODY or EXP, as well as in FORM, so you can write
+recursive and mutually recursive 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...)"
@@ -2282,7 +2291,7 @@ cl-labels
   (let ((binds ()) (newenv macroexpand-all-environment))
     (dolist (binding bindings)
       (let ((var (make-symbol (format "--cl-%s--" (car binding)))))
-	(push (cons var (cdr binding)) binds)
+	(push (cons var binding) binds)
 	(push (cons (car binding)
                     (lambda (&rest args)
                       (if (eq (car args) cl--labels-magic)
@@ -2295,12 +2304,18 @@ cl-labels
     ;; Perform self-tail call elimination.
     `(letrec ,(mapcar
                (lambda (bind)
-                 (pcase-let* ((`(,var ,sargs . ,sbody) bind))
+                 (pcase-let* ((`(,var ,fun ,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)))
+                                   (let ((parsed-body
+                                          (macroexp-parse-body sbody)))
+                                     `(cl-function
+                                       (lambda ,sargs
+                                         ,@(car parsed-body)
+                                         (cl-block ,fun
+                                           ,@(cdr parsed-body))))))
                                  newenv)))))
                (nreverse binds))
        . ,(macroexp-unprogn
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 4baf5428101..e1a521dca79 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -718,6 +718,16 @@ cl-macs--labels
                            (f lex-var)))))
       (should (equal (f nil) 'a)))))
 
+(ert-deftest cl-macs--test-flet-block ()
+  (should (equal (cl-block f1
+                   (cl-flet ((f1 (a) (cons (cl-return-from f1 a) 6)))
+                    (cons (f1 5) 6)))
+                 '(5 . 6)))
+  (should (equal (cl-block f1
+                   (cl-labels ((f1 (a) (cons (cl-return-from f1 a) 6)))
+                     (cons (f1 7) 8)))
+                 '(7 . 8))))
+
 (ert-deftest cl-flet/edebug ()
   "Check that we can instrument `cl-flet' forms (bug#65344)."
   (with-temp-buffer

Message #26 received at 74870 <at> debbugs.gnu.org (full text, mbox):

From: Jan Jouleodov <jouleodov <at> protonmail.com>
To: Stefan Monnier <monnier <at> iro.umontreal.ca>
Cc: Eli Zaretskii <eliz <at> gnu.org>, 74870 <at> debbugs.gnu.org
Subject: Re: bug#74870: cl-labels and cl-flet don't create named blocks
Date: Sat, 21 Dec 2024 16:24:34 +0000

> Never mind, it here's a better one I just pushed to `master`.
> 
> 
> Stefan

Cheers!

Message #31 received at 74870-done <at> debbugs.gnu.org (full text, mbox):

From: Stefan Kangas <stefankangas <at> gmail.com>
To: Stefan Monnier <monnier <at> iro.umontreal.ca>
Cc: Eli Zaretskii <eliz <at> gnu.org>, 74870-done <at> debbugs.gnu.org,
 Jan Jouleodov <jouleodov <at> protonmail.com>
Subject: Re: bug#74870: cl-labels and cl-flet don't create named blocks
Date: Wed, 1 Jan 2025 19:32:46 -0600

Stefan Monnier <monnier <at> iro.umontreal.ca> writes:

>>> Is there any reason why one would not want to *always* emulate the CL
>>> behavior in cl-lib? I could only think of a backward compatibility
>>> problem before CL was standardized, but I am not familiar with the time
>>> frame of cl-lib to know if that's really the case.
>> Could you try the patch below?
>
> Never mind, it here's a better one I just pushed to `master`.

I'm therefore closing this bug report.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.