From: Stefan Monnier <monnier@iro.umontreal.ca>
Date: Thu, 16 Jan 2025 22:48:21 +0000 (-0500)
Subject: (cl-block, cl-return-from): Fix bug#75498
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=f0925ead787bc91d1b6bd9969030e1aab727b45c;p=emacs.git

(cl-block, cl-return-from): Fix bug#75498

* lisp/emacs-lisp/cl-macs.el (cl-block, cl-return-from):
Change encoding so it obeys variable coping (i.e. lexical scoping when
`lexical-binding` is non-nil).
(cl--block-wrapper, cl--block-throw): Adjust accordingly.

* test/lisp/emacs-lisp/cl-macs-tests.el
(cl-macs--test-cl-block-lexbind-bug-75498): New test.

(cherry picked from commit dace7fa2ab468aeeca664541490eb9f291427a63)
---

diff --git a/etc/NEWS b/etc/NEWS
index 43eab2b17de..7091732070d 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -291,6 +291,9 @@ Emacs 25.1), and gnudoit (obsolete since Emacs 25.1).
 *** 'cl-labels' now also accepts (FUNC EXP) bindings, like 'cl-flet'.
 Such bindings make it possible to compute which function to bind to FUNC.
 
+---
+*** 'cl-block' names are now lexically scoped, as documented.
+
 ** Whitespace
 
 ---
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 @@ references may appear inside macro expansions, but not inside functions
 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 @@ This is compatible with Common Lisp, but note that `defun' and
 `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 @@ macro that returns its `&whole' argument."
 
 (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))
 
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 663961dc317..628bae36e48 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -728,6 +728,15 @@ collection clause."
                      (cons (f1 7) 8)))
                  '(7 . 8))))
 
+(ert-deftest cl-macs--test-cl-block-lexbind-bug-75498 ()
+  (should (equal
+           (let ((ret (lambda (f)
+                        (cl-block a (funcall f) (cl-return-from a :ret)))))
+             (cl-block a
+               (list :oops
+                     (funcall ret (lambda () (cl-return-from a :clo))))))
+           :clo)))
+
 (ert-deftest cl-flet/edebug ()
   "Check that we can instrument `cl-flet' forms (bug#65344)."
   (with-temp-buffer