From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Thuna Newsgroups: gmane.emacs.bugs Subject: bug#72279: [PATCH] Non-local exits from outside the lexical scope are caught by cl-block Date: Wed, 24 Jul 2024 19:36:13 +0200 Message-ID: <87wmla4rqq.fsf@gmail.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="7200"; mail-complaints-to="usenet@ciao.gmane.io" To: 72279@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Wed Jul 24 19:37:22 2024 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1sWfvW-0001oA-Eq for geb-bug-gnu-emacs@m.gmane-mx.org; Wed, 24 Jul 2024 19:37:22 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1sWfvE-0005fd-2c; Wed, 24 Jul 2024 13:37:04 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1sWfv7-0005dE-2c for bug-gnu-emacs@gnu.org; Wed, 24 Jul 2024 13:36:58 -0400 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1sWfv6-0000tm-I0 for bug-gnu-emacs@gnu.org; Wed, 24 Jul 2024 13:36:56 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1sWfvC-0006Dc-Eg for bug-gnu-emacs@gnu.org; Wed, 24 Jul 2024 13:37:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Thuna Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Wed, 24 Jul 2024 17:37:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 72279 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch X-Debbugs-Original-To: bug-gnu-emacs@gnu.org Original-Received: via spool by submit@debbugs.gnu.org id=B.172184259223856 (code B ref -1); Wed, 24 Jul 2024 17:37:02 +0000 Original-Received: (at submit) by debbugs.gnu.org; 24 Jul 2024 17:36:32 +0000 Original-Received: from localhost ([127.0.0.1]:34424 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sWfui-0006Ch-25 for submit@debbugs.gnu.org; Wed, 24 Jul 2024 13:36:32 -0400 Original-Received: from lists.gnu.org ([209.51.188.17]:46676) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sWfud-0006CY-Vq for submit@debbugs.gnu.org; Wed, 24 Jul 2024 13:36:30 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1sWfuX-0003z4-E3 for bug-gnu-emacs@gnu.org; Wed, 24 Jul 2024 13:36:21 -0400 Original-Received: from mail-wm1-x330.google.com ([2a00:1450:4864:20::330]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1sWfuV-0008I0-2j for bug-gnu-emacs@gnu.org; Wed, 24 Jul 2024 13:36:21 -0400 Original-Received: by mail-wm1-x330.google.com with SMTP id 5b1f17b1804b1-42122ac2f38so572955e9.1 for ; Wed, 24 Jul 2024 10:36:18 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1721842577; x=1722447377; darn=gnu.org; h=mime-version:message-id:date:subject:to:from:from:to:cc:subject :date:message-id:reply-to; bh=OdmZLlodoPT8xJxrWFikPqCG3MLjNxoISF7f6Elkp0Y=; b=e6yb6N0ZXyCD3ItPg6o2QwrgEPF/fG16XrZplJj4KkXtEehssrNaaNn9+VaQbkcWED LMwwzzcP+oPQ06x+Kgmw5AA3mDNI1cZiGk1NAIuxGDIQKCVEI6llACCoLI5U2XDzWgKl 0dtiBhDafMkVj6JShy4i08iEnpeYAIPHyxJBTTbHnlJZG6+Ft2JWkce5sXSeh+i/nU7Q xHT+K5NKufA69xFvJlj3wwfMK6Aco5qzl4uIgfRiyA4wE4MA/9CWcm0k5M92tJGdo09d NqPMTuvBDoGeo1wNHBDsXjC2LXeR7oCKhlEQb08NozMM/ItMg1reobvvSwzcPGOfnpAY P4mQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1721842577; x=1722447377; h=mime-version:message-id:date:subject:to:from:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=OdmZLlodoPT8xJxrWFikPqCG3MLjNxoISF7f6Elkp0Y=; b=JGhiZHlGkjUcCZqyo/f5Lvc5dNiuZ+TeJSH3YbITdsSQbW4omn6wSBUZIpmfMTmkzg 3nSWhcTZqcwab84PW7us0gSJJay9yxtvKFp87lShinYFDcnfGsz+FGJqSFZaG+CGZ24C 0paFORMrQFY1Q2qk6/ZY3hFtpnXDAvQ19w00Twjs2O8gSh6buqo8mj4IQKhGmi4JU5ty 4yOuQONWHhloUpRk5xLNux+klXY0PaFdVjuevHu/3XL/h3ktT1/Fw4CajVxZ6yRLUg8R Nw5vBxaXDRJGiLr4gIsZffm3FzIFehnqbyL10z3D3Q5at0+1clcTHsVQozQx5K/Z++ZW oWUg== X-Gm-Message-State: AOJu0YyCqtL7RpEUsKJ9sFilpQSn4i7CmsBSNEDUPz9rdKt+h++DK4Gb XcQ2F5FXxlipl//DGR8ZJY9TIOZc7SGv+1pwr8NXaZx794cNdxL0bGjvZg== X-Google-Smtp-Source: AGHT+IEPCq5/K596gfGNKgfnZJbMjQKNulDRlxsFj/TkqmnruSOmWXTk07yvKV3AtWhj4VZ1+kpvZg== X-Received: by 2002:a05:600c:3b86:b0:424:895c:b84b with SMTP id 5b1f17b1804b1-42803adc036mr2958515e9.4.1721842576292; Wed, 24 Jul 2024 10:36:16 -0700 (PDT) Original-Received: from thuna-lis3 ([85.106.105.81]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-427f9359710sm40445735e9.1.2024.07.24.10.36.14 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 24 Jul 2024 10:36:15 -0700 (PDT) Received-SPF: pass client-ip=2a00:1450:4864:20::330; envelope-from=thuna.cing@gmail.com; helo=mail-wm1-x330.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.bugs:289247 Archived-At: --=-=-= Content-Type: text/plain 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. --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-Use-uninterned-tags-in-cl-block-remove-block-wrapper.patch Content-Description: The first patch >From 4027c50645260a202e45a2a074dfeb48468394c1 Mon Sep 17 00:00:00 2001 From: Thuna 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0002-Avoid-macroexpanding-in-cl-block.patch Content-Description: The second patch >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 --=-=-=--