From 8181df542b1f57365b0a2a503b245884cb8da94d Mon Sep 17 00:00:00 2001 From: Thuna 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