From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Stefan Monnier via "Bug reports for GNU Emacs, the Swiss army knife of text editors" Newsgroups: gmane.emacs.bugs Subject: bug#74870: cl-labels and cl-flet don't create named blocks Date: Sat, 21 Dec 2024 11:14:54 -0500 Message-ID: References: <86bjxetdbp.fsf@gnu.org> Reply-To: Stefan Monnier 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="16482"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: Eli Zaretskii , 74870@debbugs.gnu.org To: Jan Jouleodov Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sat Dec 21 17:16:16 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 1tP29G-0004Ac-6x for geb-bug-gnu-emacs@m.gmane-mx.org; Sat, 21 Dec 2024 17:16:14 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tP297-0002Rx-Hp; Sat, 21 Dec 2024 11:16:05 -0500 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 1tP295-0002RT-QH for bug-gnu-emacs@gnu.org; Sat, 21 Dec 2024 11:16:03 -0500 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 1tP294-0003DY-Hm for bug-gnu-emacs@gnu.org; Sat, 21 Dec 2024 11:16:02 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:References:In-Reply-To:From:To:Subject; bh=dKjTzmuMHU4YkZ8TnH44X+nrEl+B8LNnrcYFbbN27dY=; b=Y7C4SkQHCe/2e/9zLJ3WqQmCXGyU6uLq/ehWe4aWRTWNINc2lr2pPAht3J7nf1t1ClrjrLkOSau1qF+ki+wAdk7h11QQJKgvTHVSR/9uM16zL5Q/xu9IZXLkQSzvAILK58wnEraOJiZFIvSDuSNzzgHpcUcR0cuGqTnIVMk8L7XpUv6VFsc7miWJBA5g1f7jpOO5x2XIzsa8vqcHzXCp7uanEsxtCMuv0wJ1vBE9aB5Yh/HcsjjK3RvXLXb/a2MjFr2/DWbqmJQ04dYPlMmZD/Qr7h4jxMQBSDui9us1TuEvhsXGMQm6JY5FyT+OJrieXc7aU5aMuKcr6FL1cLG8tw==; Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tP294-00035R-Bv for bug-gnu-emacs@gnu.org; Sat, 21 Dec 2024 11:16:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Stefan Monnier Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 21 Dec 2024 16:16:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 74870 X-GNU-PR-Package: emacs Original-Received: via spool by 74870-submit@debbugs.gnu.org id=B74870.173479770811442 (code B ref 74870); Sat, 21 Dec 2024 16:16:02 +0000 Original-Received: (at 74870) by debbugs.gnu.org; 21 Dec 2024 16:15:08 +0000 Original-Received: from localhost ([127.0.0.1]:47401 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tP28B-0002yU-Ii for submit@debbugs.gnu.org; Sat, 21 Dec 2024 11:15:08 -0500 Original-Received: from mailscanner.iro.umontreal.ca ([132.204.25.50]:22195) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tP289-0002xb-GU for 74870@debbugs.gnu.org; Sat, 21 Dec 2024 11:15:06 -0500 Original-Received: from pmg2.iro.umontreal.ca (localhost.localdomain [127.0.0.1]) by pmg2.iro.umontreal.ca (Proxmox) with ESMTP id 4699E804BC; Sat, 21 Dec 2024 11:14:58 -0500 (EST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=iro.umontreal.ca; s=mail; t=1734797697; bh=ZTau2/n6QItaExOdR5i1v03J6XOnZPvJw1EY3dttkVI=; h=From:To:Cc:Subject:In-Reply-To:References:Date:From; b=PFd4XYz/qVbRDgprEisgYhn35J/yMovPiDA72/3ao3zlcuKCz9Jq1g7pJSx3vFRBY KfAx5+Y9PDxvc8CdwhFA3DwThdMlmbQxJcezZUsunAlSMHvEJCETey0FcIsx98+AJP 8cvSh1ORLD/G51Ob8ghRhBdm5F2KJ9uCd4qsgS/O0CYtnZzArTKZH7+28dP04TEi0f 6tGpr2fchmPOMw8rZNov9OFmP1TczN1SosU7Jlb/YOmAp4cnk/XHSHO0ZC5D0rdVrl 59yPcQ+bo80ShGNPpkK9V8oBntDCfoYPfBpQ4MoDR4WLdpJgNVvRZayeOBYEF58wBB QQtxAxHAMbmxQ== Original-Received: from mail01.iro.umontreal.ca (unknown [172.31.2.1]) by pmg2.iro.umontreal.ca (Proxmox) with ESMTP id 2319C80758; Sat, 21 Dec 2024 11:14:57 -0500 (EST) Original-Received: from asado (unknown [199.119.74.1]) by mail01.iro.umontreal.ca (Postfix) with ESMTPSA id DA2C21200F0; Sat, 21 Dec 2024 11:14:56 -0500 (EST) In-Reply-To: (Stefan Monnier's message of "Sat, 21 Dec 2024 10:44:04 -0500") 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:297536 Archived-At: --=-=-= Content-Type: text/plain >> Is there any reason why one would not want to *always* emulate the CL >> behavior in cl-lib? I could only think of a backward compatibility >> problem before CL was standardized, but I am not familiar with the time >> frame of cl-lib to know if that's really the case. > Could you try the patch below? Never mind, it here's a better one I just pushed to `master`. Stefan --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=cl-labels.patch commit 476426168106dbcee67d8ea667e11ebe80c7aaed Author: Stefan Monnier Date: Sat Dec 21 11:13:07 2024 -0500 (cl-flet, cl-labels): Fix bug#74870 * lisp/emacs-lisp/cl-macs.el (cl-flet, cl-labels): Wrap function bodies in `cl-block`. * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--test-flet-block): New test. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 65bc2cb9173..b1c42a23acd 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2071,7 +2071,8 @@ cl-flet FUNC is the function name, and EXP is an expression that returns the function value to which it should be bound, or it can take the more common form (FUNC ARGLIST BODY...) which is a shorthand -for (FUNC (lambda ARGLIST BODY)). +for (FUNC (lambda ARGLIST BODY)) where BODY is wrapped in +a `cl-block' named FUNC. FUNC is defined only within FORM, not BODY, so you can't write recursive function definitions. Use `cl-labels' for that. See @@ -2096,15 +2097,22 @@ cl-flet cl-declarations body))) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) - (let ((var (make-symbol (format "--cl-%s--" (car binding)))) - (args-and-body (cdr binding))) - (if (and (= (length args-and-body) 1) - (macroexp-copyable-p (car args-and-body))) + (let* ((var (make-symbol (format "--cl-%s--" (car binding)))) + (args-and-body (cdr binding)) + (args (car args-and-body)) + (body (cdr args-and-body))) + (if (and (null body) + (macroexp-copyable-p args)) ;; Optimize (cl-flet ((fun var)) body). - (setq var (car args-and-body)) - (push (list var (if (= (length args-and-body) 1) - (car args-and-body) - `(cl-function (lambda . ,args-and-body)))) + (setq var args) + (push (list var (if (null body) + args + (let ((parsed-body (macroexp-parse-body body))) + `(cl-function + (lambda ,args + ,@(car parsed-body) + (cl-block ,(car binding) + ,@(cdr parsed-body))))))) binds)) (push (cons (car binding) (lambda (&rest args) @@ -2271,10 +2279,11 @@ cl-labels where EXP is a form that should return the function to bind to the function name FUNC, or (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the -forms of the function body. FUNC is in scope in any BODY or EXP, as well -as FORM, so you can write recursive and mutually recursive -function definitions, with the caveat that EXPs are evaluated in sequence -and you cannot call a FUNC before its EXP has been evaluated. +forms of the function body. BODY is wrapped in a `cl-block' named FUNC. +FUNC is in scope in any BODY or EXP, as well as in FORM, so you can write +recursive and mutually recursive function definitions, with the caveat +that EXPs are evaluated in sequence and you cannot call a FUNC before its +EXP has been evaluated. See info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" @@ -2282,7 +2291,7 @@ cl-labels (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) (let ((var (make-symbol (format "--cl-%s--" (car binding))))) - (push (cons var (cdr binding)) binds) + (push (cons var binding) binds) (push (cons (car binding) (lambda (&rest args) (if (eq (car args) cl--labels-magic) @@ -2295,12 +2304,18 @@ cl-labels ;; Perform self-tail call elimination. `(letrec ,(mapcar (lambda (bind) - (pcase-let* ((`(,var ,sargs . ,sbody) bind)) + (pcase-let* ((`(,var ,fun ,sargs . ,sbody) bind)) `(,var ,(cl--self-tco-on-form var (macroexpand-all (if (null sbody) sargs ;A (FUNC EXP) definition. - `(cl-function (lambda ,sargs . ,sbody))) + (let ((parsed-body + (macroexp-parse-body sbody))) + `(cl-function + (lambda ,sargs + ,@(car parsed-body) + (cl-block ,fun + ,@(cdr parsed-body)))))) newenv))))) (nreverse binds)) . ,(macroexp-unprogn diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 4baf5428101..e1a521dca79 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -718,6 +718,16 @@ cl-macs--labels (f lex-var))))) (should (equal (f nil) 'a))))) +(ert-deftest cl-macs--test-flet-block () + (should (equal (cl-block f1 + (cl-flet ((f1 (a) (cons (cl-return-from f1 a) 6))) + (cons (f1 5) 6))) + '(5 . 6))) + (should (equal (cl-block f1 + (cl-labels ((f1 (a) (cons (cl-return-from f1 a) 6))) + (cons (f1 7) 8))) + '(7 . 8)))) + (ert-deftest cl-flet/edebug () "Check that we can instrument `cl-flet' forms (bug#65344)." (with-temp-buffer --=-=-=--