bug#75498: 31.0.50; cl-block is not lexically scoped

bug#75498: 31.0.50; cl-block is not lexically scoped

[Ihor Radchenko]

According to the docstring, `cl-block' should be lexically scoped:

    Code inside the BODY forms can call cl-return-from
    to jump prematurely out of the block.  This differs from catch and throw
    in two respects:  First, the NAME is an unevaluated symbol rather than a
    quoted symbol or other form; and second, NAME is lexically rather than
    dynamically scoped:  Only references to it within BODY will work.  These
    references may appear inside macro expansions, but not inside functions
    called from BODY.

But try the following reproducer:

1. create file test.el

;; -*- lexical-binding: t; -*-

(defun return-from-x ()
  (cl-return-from x 'dynamic))

(defun x-block ()
  (cl-block x
    (return-from-x)
    (cl-return-from x 'lexical)))

2. (load "/path/to/test.el)
3. M-: (x-block)

Expected: 'lexical is returned.
Observed: 'dynamic is returned.

In GNU Emacs 31.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version
 3.24.42, cairo version 1.18.2) of 2025-01-10 built on localhost
Repository revision: e8deac66adef279a15c806d7547a7610b0189795
Repository branch: scratch/igc
Windowing system distributor 'The X.Org Foundation', version 11.0.12101014
System Description: Gentoo Linux

Configured using:
 'configure --with-mps=yes --with-native-compilation 'CFLAGS=-g3
 -I/opt/mps/include -L/opt/mps/lib'
 JAVAC=/etc/java-config-2/current-system-vm/bin/javac
 PKG_CONFIG_PATH=/usr/share/guile-data/3.0/pkgconfig'

-- 
Ihor Radchenko // yantar92,
Org mode maintainer,
Learn more about Org mode at <https://orgmode.org/>.
Support Org development at <https://liberapay.com/org-mode>,
or support my work at <https://liberapay.com/yantar92>

bug#75498: 31.0.50; cl-block is not lexically scoped

[Eli Zaretskii]

> From: Ihor Radchenko <yantar92@posteo.net>
> Date: Sat, 11 Jan 2025 16:10:39 +0000
> 
> 
> According to the docstring, `cl-block' should be lexically scoped:
> 
>     Code inside the BODY forms can call cl-return-from
>     to jump prematurely out of the block.  This differs from catch and throw
>     in two respects:  First, the NAME is an unevaluated symbol rather than a
>     quoted symbol or other form; and second, NAME is lexically rather than
>     dynamically scoped:  Only references to it within BODY will work.  These
>     references may appear inside macro expansions, but not inside functions
>     called from BODY.
> 
> But try the following reproducer:
> 
> 1. create file test.el
> 
> ;; -*- lexical-binding: t; -*-
> 
> (defun return-from-x ()
>   (cl-return-from x 'dynamic))
> 
> (defun x-block ()
>   (cl-block x
>     (return-from-x)
>     (cl-return-from x 'lexical)))
> 
> 2. (load "/path/to/test.el)
> 3. M-: (x-block)
> 
> Expected: 'lexical is returned.
> Observed: 'dynamic is returned.

Adding Stefan.

bug#75498: 31.0.50; cl-block is not lexically scoped

[Stefan Monnier via Bug reports for GNU Emacs, the Swiss army knife of text editors]

>> According to the docstring, `cl-block' should be lexically scoped:
>> 
>>     Code inside the BODY forms can call cl-return-from
>>     to jump prematurely out of the block.  This differs from catch and throw
>>     in two respects:  First, the NAME is an unevaluated symbol rather than a
>>     quoted symbol or other form; and second, NAME is lexically rather than
>>     dynamically scoped:  Only references to it within BODY will work.  These
>>     references may appear inside macro expansions, but not inside functions
>>     called from BODY.

Not sure what I was thinking when I wrote that code.
IIRC someone else reported basically this bug already some years ago,
and I lost track of it somehow.
I think the patch below might do the trick.


        Stefan


diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 01e7b35cc52..7559c58e77a 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -901,9 +901,13 @@ cl-block
 called from BODY."
   (declare (indent 1) (debug (symbolp body)))
   (if (cl--safe-expr-p `(progn ,@body)) `(progn ,@body)
-    `(cl--block-wrapper
-      (catch ',(intern (format "--cl-block-%s--" name))
-        ,@body))))
+    (let ((var (intern (format "--cl-block-%s--" name))))
+      `(cl--block-wrapper
+        ;; Build a unique "tag" in the form of a fresh cons.
+        ;; We include `var' in the cons, just in case it help debugging.
+        (let ((,var (cons ',var nil)))
+         (catch ,var
+           ,@body))))))
 
 ;;;###autoload
 (defmacro cl-return (&optional result)
@@ -921,7 +925,7 @@ cl-return-from
 `defmacro' do not create implicit blocks as they do in Common Lisp."
   (declare (indent 1) (debug (symbolp &optional form)))
   (let ((name2 (intern (format "--cl-block-%s--" name))))
-    `(cl--block-throw ',name2 ,result)))
+    `(cl--block-throw ,name2 ,result)))
 
 
 ;;; The "cl-loop" macro.
@@ -3672,20 +3676,24 @@ cl-compiler-macroexpand
 
 (defvar cl--active-block-names nil)
 
-(cl-define-compiler-macro cl--block-wrapper (cl-form)
-  (let* ((cl-entry (cons (nth 1 (nth 1 cl-form)) nil))
-         (cl--active-block-names (cons cl-entry cl--active-block-names))
-         (cl-body (macroexpand-all      ;Performs compiler-macro expansions.
-                   (macroexp-progn (cddr cl-form))
-                   macroexpand-all-environment)))
-    ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
-    ;; to indicate that this return value is already fully expanded.
-    (if (cdr cl-entry)
-        `(catch ,(nth 1 cl-form) ,@(macroexp-unprogn cl-body))
-      cl-body)))
+(cl-define-compiler-macro cl--block-wrapper (form)
+  (pcase form
+    (`(let ((,var . ,val)) (catch ,var . ,body))
+     (let* ((cl-entry (cons var nil))
+            (cl--active-block-names (cons cl-entry cl--active-block-names))
+            (cl-body (macroexpand-all      ;Performs compiler-macro expansions.
+                      (macroexp-progn body)
+                      macroexpand-all-environment)))
+       ;; FIXME: To avoid re-applying macroexpand-all, we'd like to be able
+       ;; to indicate that this return value is already fully expanded.
+       (if (cdr cl-entry)
+           `(let ((,var . ,val)) (catch ,var ,@(macroexp-unprogn cl-body)))
+           cl-body)))
+    ;; `form' was somehow mangled, god knows what happened, let's not touch it.
+    (_ form)))
 
 (cl-define-compiler-macro cl--block-throw (cl-tag cl-value)
-  (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names)))
+  (let ((cl-found (and (symbolp cl-tag) (assq cl-tag cl--active-block-names))))
     (if cl-found (setcdr cl-found t)))
   `(throw ,cl-tag ,cl-value))