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)