Re: Getting rid of cl--block-wrapper and cl--block-throw

[Thuna <thuna.cing@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 308 bytes --]

I am not privy to the historical details but looking at the logs it
looks like the previous code was written at a time when
`macroexpand-all' was not available and never touched afterwards.

What I have in mind is similar to the patch I've attached, though it
might be better to move this to bug-gnu-emacs.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Patch moving cl--block-{wrapper,throw} functionality into cl-{block,return-from} --]
[-- Type: text/x-patch, Size: 3060 bytes --]

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)