From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: akater Newsgroups: gmane.emacs.devel Subject: Re: [PATCH] Some improvements for cl-flet Date: Wed, 03 Nov 2021 12:59:56 +0000 Message-ID: <87h7ctqtrn.fsf@gmail.com> References: <87bl4zqnqn.fsf@gmail.com> <87mto2gbpu.fsf@gmail.com> <87k0j6gbjg.fsf@gmail.com> <87pmshqvfk.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="40676"; mail-complaints-to="usenet@ciao.gmane.io" Cc: emacs-devel@gnu.org To: Stefan Monnier Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Wed Nov 03 14:13:10 2021 Return-path: Envelope-to: ged-emacs-devel@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 1miG4k-000AKE-7n for ged-emacs-devel@m.gmane-mx.org; Wed, 03 Nov 2021 14:13:10 +0100 Original-Received: from localhost ([::1]:33230 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1miG4i-0006eo-2n for ged-emacs-devel@m.gmane-mx.org; Wed, 03 Nov 2021 09:13:08 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:58364) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1miG3M-0005Vd-Kn for emacs-devel@gnu.org; Wed, 03 Nov 2021 09:11:44 -0400 Original-Received: from mail-ed1-x52d.google.com ([2a00:1450:4864:20::52d]:39739) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1miG3K-0008GF-78 for emacs-devel@gnu.org; Wed, 03 Nov 2021 09:11:44 -0400 Original-Received: by mail-ed1-x52d.google.com with SMTP id r12so9037890edt.6 for ; Wed, 03 Nov 2021 06:11:41 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=from:to:cc:subject:in-reply-to:references:date:message-id :mime-version; bh=C8lLxdgyu/Pu2lF3ZtXLVRP39YNNhfGaI+ZQJe2KB6A=; b=Zy3NQzinSFFAuxGhPd2J8q3E+7916K8Gyk7H1A1G+MzqxW9ogkAeGIDveSqX/Q+jNU NU3r8z++oA5VVDjiZf8UEwXf9+T5L8X0W0pAtwTldNG+f1Lgs9+8p63z+HVFCnVCZJqS /j3JN586R5+JaQ/XrRZOZFWIskW5IR4EXwePWdMBPHiscNbnbUnSTnwr1lKC/ws12l63 vyn9aEK1nx+NtG+ZH/KQqCUsnPkJc+p845hclWLAqvHW6+KmprYhFDtpvXHC8qX3KpBJ B89ilaKBpyKY+1a/sVNcakr+o9j4MOmWsVfpJcZdTvbUTYwjHKQRWxIK3ltEfWcMy6bE +ugA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:from:to:cc:subject:in-reply-to:references:date :message-id:mime-version; bh=C8lLxdgyu/Pu2lF3ZtXLVRP39YNNhfGaI+ZQJe2KB6A=; b=fqQSety8NwH9Fc60MoWv7N7Yu/OD+Dfjjh39MvkpDGClzwdti12Nwio9h219wSgSjE AAoPazi3HDdYJAKgDBkD+EQqjSNnfT9khL4oih9GruRO65KOXwhHoXTAPg4+xw9CyvBy WLBoDYoWWSdx27LzhDWO3hqCOy3/lCc+1A1awwRGPpy8lQ0FFSaOAsSmnsgOrRhq62tg hOaHIl7IZVtym6ppt13ziVkfOVH78zrd+vH1b1qEN25fp3/gRidp0DRE/+ayg/K1pPW2 pW4vgnSjWYwlZ1CCBPKeBlpip2o30Ep+1Z3wcpTM/LXpjJHzCRNgvVDZS9T8FW0ukaGb EFyw== X-Gm-Message-State: AOAM532x+iWgGvdDNZZq1dwIcAY1mfiKiLkApXCcZWFniVM6q79lvE05 VipfP8ziUZgIbYNxPzUiylHr4+t824w= X-Google-Smtp-Source: ABdhPJwq3VNTJHBxkAd2seF5qA+BYpBCpSUts02TOZ+GW07OchMhAL3MyMiROR8yjejfvZng3zWjiw== X-Received: by 2002:a17:906:70c5:: with SMTP id g5mr55501952ejk.63.1635945099905; Wed, 03 Nov 2021 06:11:39 -0700 (PDT) Original-Received: from localhost (tor-exit-53.for-privacy.net. [185.220.101.53]) by smtp.googlemail.com with ESMTPSA id w18sm1471977edc.4.2021.11.03.06.11.38 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 03 Nov 2021 06:11:39 -0700 (PDT) In-Reply-To: Received-SPF: pass client-ip=2a00:1450:4864:20::52d; envelope-from=nuclearspace@gmail.com; helo=mail-ed1-x52d.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: emacs-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.io gmane.emacs.devel:278571 Archived-At: --=-=-= Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" --==-=-= Content-Type: text/plain Sorry it took so long; Emacs build broke several times, an on top of that Org is having some tectonic changes as well, and I've had my own time trouble. I tried the following patch. Stefan Monnier writes: > But that's a very minor cosmetic detail. Either way works, I was just > curious why you did it this way. > > > Stefan > > > diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el > index 1852471bcbb..ad0477e3b68 100644 > --- a/lisp/emacs-lisp/cl-macs.el > +++ b/lisp/emacs-lisp/cl-macs.el > @@ -2030,7 +2030,10 @@ cl-flet > (let ((binds ()) (newenv macroexpand-all-environment)) > (dolist (binding bindings) > (let ((var (make-symbol (format "--cl-%s--" (car binding)))) > + (fname (car binding)) > (args-and-body (cdr binding))) > + (if (eq (car-safe fname) 'setf) > + (setq fname (gv-setter (cadr fname)))) > (if (and (= (length args-and-body) 1) (symbolp (car args-and-body))) > ;; Optimize (cl-flet ((fun var)) body). > (setq var (car args-and-body)) > @@ -2038,7 +2041,7 @@ cl-flet > (car args-and-body) > `(cl-function (lambda . ,args-and-body)))) > binds)) > - (push (cons (car binding) > + (push (cons fname > (lambda (&rest args) > (if (eq (car args) cl--labels-magic) > (list cl--labels-magic var) Four of my tests failed which did pass for the solution I've proposed. The first case is not even supported with global functions in Elisp so I'm not sure how relevant it is. Here are the summaries; the rest (results vs expected, some comments) is attached. I've received some complaints about my usage of Org markup in the mailing list so details are omitted from the mail body. ** TEST-FAILED setf with #'(setf ..) in body ** TEST-FAILED non-setf local function within (setf ..) local function ** TEST-FAILED Local setf function within local non-setf function within local setf function ** TEST-FAILED Eponymous local macro, local function and its setf, local macro, local function --==-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQJLBAEBCgA1FiEEgu5SJRdnQOF34djNsr6xYbHsf0QFAmGCh9EXHG51Y2xlYXJz cGFjZUBnbWFpbC5jb20ACgkQsr6xYbHsf0Ra/Q//a10n4MSChfVJbICDoZLu4yXK LT/aJsB2voKYGUhN5SN+5CnE0FOJ0/pSgC8esYysypFGqcQg2i9VPoV4Cxe0TzNV TOK4/i/ztjxLVLdQSpo82etlf7phQC9S5fRPdOKYQMNT8ixUFBom6o9ZLjhVHtSG /EFtgCEGKroU5iuo1JyXwMszceIahN4D7YEBoVzBSxYmCX6boMa2MTsJSp26gUtw 3yKipIpMejxSci87OLir5qeY0H50KsLA2g5YuuclZXJlC/UQZgTeeX40RHsHMlZe MX1L/bExyMWAhNKPC6Z2ZE6RP28WHiJyljgLVqw120VrhryC26NK2K6QlgNBq/FX zxHRdJ3zew0qbEMqUUUXA71Ezk/dxzGbLDLsBFmACkxpxqDmULuCGmUtlwuMQIQQ FN8YbALaUlEpy5SkePdOgmSG/4WGRg3OREILbuWZtY2OcEpMB/5O0QKB/z4MvLzk x/cP5tsLdmErjEgBtqDZVWid/iWFugVpLgVh6MDBhQqHTJAtdKfCtGyJoarCWOVj 2/pgz4xw4KUFjcOcMR60EmxcB3mEMc4gSDw9RKS2RcI0nbPYcJlZsN8lEbO4FUwO /O8wMRvChdxKXKyR3eR16pI/wlL1br/+od3wWVLIWCkPAO1X49+bmrtX759OSfR3 8s5ctIVbn18WdkLMjh0= =hpDs -----END PGP SIGNATURE----- --==-=-=-- --=-=-= Content-Type: text/plain Content-Disposition: attachment; filename=stefan-monnier-local-setf.org Content-Description: Failed tests for gv-setter-based implementation of local setfs #+title: Improving cl-flet in Emacs 29: Local setf solution by Stefan Monnier #+author: =#= #+property: header-args :lexical t #+startup: nologdone show2levels #+todo: TEST-FAILED(f) | TEST-PASSED(p) * Definition #+begin_src emacs-lisp :results none (defmacro cl-flet (bindings &rest body) "Make local function definitions. Each definition can take the form (FUNC EXP) where 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)). FUNC is defined only within FORM, not BODY, so you can't write recursive function definitions. Use `cl-labels' for that. See info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug ((&rest [&or (&define name function-form) (cl-defun)]) cl-declarations body))) (let ((binds ()) (newenv macroexpand-all-environment)) (dolist (binding bindings) (let ((var (make-symbol (format "--cl-%s--" (car binding)))) (fname (car binding)) (args-and-body (cdr binding))) (if (eq 'setf (car-safe fname)) (setq fname (gv-setter (cadr fname)))) (if (and (= (length args-and-body) 1) (symbolp (car args-and-body))) ;; 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)))) binds)) (push (cons fname (lambda (&rest args) (if (eq (car args) cl--labels-magic) (list cl--labels-magic var) `(funcall ,var ,@args)))) newenv))) ;; FIXME: Eliminate those functions which aren't referenced. (macroexp-let* (nreverse binds) (macroexpand-all `(progn ,@body) ;; Don't override lexical-let's macro-expander. (if (assq 'function newenv) newenv (cons (cons 'function #'cl--labels-convert) newenv)))))) #+end_src * Tests ** TEST-FAILED setf with #'(setf ..) in body The difference in ~(let ((setf-arg-0 t)) ..)~ is irrelevant, what's relevant is, ~#'(setf kar)~ is not recognized. #+begin_src emacs-lisp :tangle no :results code :wrap example emacs-lisp (macroexpand-1 `(cl-flet (((setf kar) (new) 'just-an-example)) (setf (kar) t) (funcall #'(setf kar) t))) #+end_src #+RESULTS: #+begin_example emacs-lisp (let* ((--cl-\(setf\ kar\)-- (cl-function (lambda (new) 'just-an-example)))) (progn (funcall --cl-\(setf\ kar\)-- t) (funcall #'(setf kar) t))) #+end_example #+EXPECTED: #+begin_example emacs-lisp (let* ((--cl-\(setf\ kar\)-- (cl-function (lambda (new) 'just-an-example)))) (progn (let ((setf-arg-0 t)) (funcall --cl-\(setf\ kar\)-- setf-arg-0)) (funcall --cl-\(setf\ kar\)-- t))) #+end_example ** TEST-FAILED non-setf local function within (setf ..) local function #+begin_src emacs-lisp :tangle no :results code :wrap example emacs-lisp (condition-case err (let ((x (cons (cons nil nil) nil))) (cl-flet ((kar (x) (car x)) ((setf kar) (new cons) (setf (car cons) new))) (setf (kar (kar x)) t)) x) (t err)) #+end_src #+RESULTS: #+begin_example emacs-lisp (void-function \(setf\ funcall\)) #+end_example #+EXPECTED: #+begin_example emacs-lisp ((t)) #+end_example ** TEST-FAILED Local setf function within local non-setf function within local setf function #+begin_src emacs-lisp :tangle no :results code :wrap example emacs-lisp (condition-case err (let ((x (cons (cons nil nil) nil)) (y (cons (cons nil nil) nil))) (cl-flet ((kar (x) (car x)) ((setf kar) (new cons) (setf (car cons) new))) (setf (kar (kar (setf (kar y) x))) t)) (cl-values x y)) (t err)) #+end_src #+RESULTS: #+begin_example emacs-lisp (void-function \(setf\ funcall\)) #+end_example #+EXPECTED: #+begin_example emacs-lisp (((t)) (((t)))) #+end_example ** TEST-FAILED Eponymous local macro, local function and its setf, local macro, local function #+begin_src emacs-lisp :tangle no :results code :wrap example emacs-lisp (condition-case err (let (result) (cl-macrolet ((f (x) ``(f1 ,,x))) (push (f 0) result) (cl-flet ((f (x) `(f2 ,x)) ((setf f) (new x) (f (list x new)))) (push (f 1) result) (push (setf (f (f (setf (f 2) 3))) (f 4)) result) (cl-macrolet ((f (x) `(car (list `(f3 ,,x))))) (push (f 5) result) (push (setf (f (f (f 6))) (f 8)) result) (cl-flet ((f (x) `(f4 ,x))) (push (f 9) result) (push (setf (f (f (setf (f 10) 11))) (f 12)) result))))) result) (t err)) #+end_src #+RESULTS: #+begin_example emacs-lisp (void-function \(setf\ funcall\)) #+end_example #+EXPECTED: #+begin_example emacs-lisp ((f1 ((f4 (f1 (10 11))) (f4 12))) (f4 9) (f3 8) (f3 5) (f1 ((f2 (f1 (2 3))) (f2 4))) (f2 1) (f1 0)) #+end_example --=-=-=--