Subject: [PATCH] Non-local exits from outside the lexical scope are caught by cl-block

From: Thuna <[email-masked]>
Date: Wed, 24 Jul 2024 19:36:13 +0200

Since the thrown and caught tags in `cl-block' and `cl-return-from' are
interned and deterministic, a `cl-block' catches `cl-return-from's with
the corresponding names even from outside the current lexical scope.

The only mechanism in place to stop this is the compiler macro around
cl--block-catch, which removes the block if no approriate returns are
found, however not only is this bound to break if the compiler macro
fails to expand, a valid exit is all that is needed to work around this.

  (defun foo () (cl-return "ruh roh"))
  (cl-block nil (foo) (cl-return t)) ; => "ruh ruh"

The first patch attached attempts to solve this by moving the
functionality of the wrapper compiler macros to the macros themselves
and by using uninterned symbols for the thrown and caught tags,
communicated by the block to the corresponding returns.  All the
existing tests seemed to run just fine but I did not do any
comprehensive testing (and there doesn't appear to be any relevant
suites either).

I do take minor issue with `macroexpand-all'ing all things inside a
block, making debugging via macrostep really annoying, but I don't know
of a better solution, outside of communicating the tag during
evaluation, which would look something like the second patch.

PS. I would also like to have a discussion about a problem that I have
noticed when trying to build with the second patch, maybe here maybe in
another bug: Because struct slots are defined using `cl-defsubst', the
whole body is wrapped in a `cl-block'.  The only reason `setf' works
with such slots is because `cl-block' expands into the body itself when
there are no `cl-return's.  If it were to instead expand into a `catch'
- whether because there is a `cl-return' or because `cl-block' is
modified to always expandi into a `catch' as it is in my second patch -
the setf will expand into (setf catch) which is not defined.  I see two
possible solutions, either define a (setf catch) or switch to defsubst
instead of cl-defsubst.

>From 4027c50645260a202e45a2a074dfeb48468394c1 Mon Sep 17 00:00:00 2001
From: Thuna <[email-masked]>
Date: Wed, 24 Jul 2024 18:41:25 +0200
Subject: [PATCH 1/2] Use uninterned tags in cl-block, remove block wrappers

* lisp/emacs-lisp/cl-macs.el (cl-block): Macroexpand the body with its
tag in cl--active-block-names, if any `cl-return-from' or `cl-return'
with the appropriate name is found then have them throw the communicated
tag, otherwise simply return the body itself.
(cl-return-from): If a block was established with the appropriate name,
use throw using its tag.  Otherwise use a newly created tag which is
guaranteed to signal a no-catch and emit a macroexpand warning.
(cl--block-wrapper cl--block-throw): Remove compiler macros.
* lisp/emacs-lisp/cl-lib.el (cl--block-wrapper cl--block-throw): Remove
aliases.  Remove the now empty "Blocks and exits" section.
---
 lisp/emacs-lisp/cl-lib.el  |  6 ------
 lisp/emacs-lisp/cl-macs.el | 44 ++++++++++++++------------------------
 2 files changed, 16 insertions(+), 34 deletions(-)

diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index 108dcd31f48..56c05aa0db3 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -183,12 +183,6 @@ substring
                                            ,getter ,start ,end ,v))
                         ,v))))))))
 
-;;; Blocks and exits.
-
-(defalias 'cl--block-wrapper 'identity)
-(defalias 'cl--block-throw 'throw)
-
-
 ;;; Multiple values.
 ;; True multiple values are not supported, or even
 ;; simulated.  Instead, cl-multiple-value-bind and friends simply expect
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 2e501005bf7..31b88aec889 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -889,6 +889,8 @@ cl-etypecase
 
 ;;; Blocks and exits.
 
+(defvar cl--active-block-names nil)
+
 ;;;###autoload
 (defmacro cl-block (name &rest body)
   "Define a lexically-scoped block named NAME.
@@ -900,10 +902,12 @@ cl-block
 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* ((cl-entry (list name (make-symbol (symbol-name name)) nil))
+         (cl--active-block-names (cons cl-entry cl--active-block-names))
+         (body (macroexpand-all (macroexp-progn body) macroexpand-all-environment)))
+    (if (nth 2 cl-entry)           ; a corresponding cl-return was found
+        `(catch ',(nth 1 cl-entry) ,@(macroexp-unprogn body))
+      body)))
 
 ;;;###autoload
 (defmacro cl-return (&optional result)
@@ -920,9 +924,14 @@ cl-return-from
 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)))
-
+  (let ((cl-entry (assq name cl--active-block-names)))
+    (if (not cl-entry)
+        (macroexp-warn-and-return
+         (format "`cl-return-from' %S encountered with no corresponding `cl-block'" name)
+         ;; This will always be a no-catch
+         `(throw ',(make-symbol (symbol-name name)) ,result))
+      (setf (nth 2 cl-entry) t)
+      `(throw ',(nth 1 cl-entry) ,result))))
 
 ;;; The "cl-loop" macro.
 
@@ -3635,27 +3644,6 @@ cl-compiler-macroexpand
 	     (not (eq form (setq form (apply handler form (cdr form))))))))
   form)
 
-;; Optimize away unused block-wrappers.
-
-(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-throw (cl-tag cl-value)
-  (let ((cl-found (assq (nth 1 cl-tag) cl--active-block-names)))
-    (if cl-found (setcdr cl-found t)))
-  `(throw ,cl-tag ,cl-value))
-
 ;; Compile-time optimizations for some functions defined in this package.
 
 (defun cl--compiler-macro-member (form a list &rest keys)
-- 
2.44.2

>From 8181df542b1f57365b0a2a503b245884cb8da94d Mon Sep 17 00:00:00 2001
From: Thuna <[email-masked]>
Date: Wed, 24 Jul 2024 18:47:40 +0200
Subject: [PATCH 2/2] Avoid macroexpanding in cl-block

* lisp/emacs-lisp/cl-macs.el (cl-block): Communicate the tag during
evaluation via a lexical variable using the symbol kept in
`cl--active-block-names-var'.
(cl-return-from): Obtain the tag to throw by looking at the lexical
variable represented by the symbol kept in `cl--active-block-names-var'.
(cl--active-block-names): Remove variable.
(cl--active-block-names-var): Add variable.
---
 lisp/emacs-lisp/cl-macs.el | 26 +++++++++++---------------
 1 file changed, 11 insertions(+), 15 deletions(-)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 31b88aec889..07fc8ba7e73 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -889,7 +889,7 @@ cl-etypecase
 
 ;;; Blocks and exits.
 
-(defvar cl--active-block-names nil)
+(defvar cl--active-block-names-var '#:cl--active-block-names)
 
 ;;;###autoload
 (defmacro cl-block (name &rest body)
@@ -902,12 +902,12 @@ cl-block
 references may appear inside macro expansions, but not inside functions
 called from BODY."
   (declare (indent 1) (debug (symbolp body)))
-  (let* ((cl-entry (list name (make-symbol (symbol-name name)) nil))
-         (cl--active-block-names (cons cl-entry cl--active-block-names))
-         (body (macroexpand-all (macroexp-progn body) macroexpand-all-environment)))
-    (if (nth 2 cl-entry)           ; a corresponding cl-return was found
-        `(catch ',(nth 1 cl-entry) ,@(macroexp-unprogn body))
-      body)))
+  (let ((block-name (make-symbol (symbol-name name))))
+    `(let ((,cl--active-block-names-var
+            (cl-acons ',name ',block-name
+                      (ignore-error void-variable
+                        ,cl--active-block-names-var))))
+       (catch ',block-name ,@body))))
 
 ;;;###autoload
 (defmacro cl-return (&optional result)
@@ -924,14 +924,10 @@ cl-return-from
 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 ((cl-entry (assq name cl--active-block-names)))
-    (if (not cl-entry)
-        (macroexp-warn-and-return
-         (format "`cl-return-from' %S encountered with no corresponding `cl-block'" name)
-         ;; This will always be a no-catch
-         `(throw ',(make-symbol (symbol-name name)) ,result))
-      (setf (nth 2 cl-entry) t)
-      `(throw ',(nth 1 cl-entry) ,result))))
+  `(let ((block-name
+          (cdr (assq ',name (ignore-error void-variable
+                              ,cl--active-block-names-var)))))
+     (throw (or block-name ',(make-symbol (symbol-name name))) ,result)))
 
 ;;; The "cl-loop" macro.
 
-- 
2.44.2