From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: "Basil L. Contovounesios" via "Bug reports for GNU Emacs, the Swiss army knife of text editors" Newsgroups: gmane.emacs.bugs Subject: bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter Date: Sat, 22 Oct 2022 18:01:38 +0300 Message-ID: <87eduz6gx9.fsf@tcd.ie> References: <87r0zaxeox.fsf@tcd.ie> <874jw6xe9h.fsf@tcd.ie> <87wn906765.fsf@tcd.ie> <87ilkkhvdn.fsf@tcd.ie> Reply-To: "Basil L. Contovounesios" 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="31685"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Gnus/5.13 (Gnus v5.13) Cc: 58531@debbugs.gnu.org To: Stefan Monnier Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sun Oct 23 22:48:46 2022 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 1omhtm-00083d-IP for geb-bug-gnu-emacs@m.gmane-mx.org; Sun, 23 Oct 2022 22:48:46 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1omgd9-00017b-6T for geb-bug-gnu-emacs@m.gmane-mx.org; Sun, 23 Oct 2022 15:27:31 -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 1omG0h-0006kq-2l for bug-gnu-emacs@gnu.org; Sat, 22 Oct 2022 11:02:03 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1omG0g-0001Ws-ST for bug-gnu-emacs@gnu.org; Sat, 22 Oct 2022 11:02:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1omG0g-0001Bp-NS for bug-gnu-emacs@gnu.org; Sat, 22 Oct 2022 11:02:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: "Basil L. Contovounesios" Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 22 Oct 2022 15:02:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58531 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 58531-submit@debbugs.gnu.org id=B58531.16664509134543 (code B ref 58531); Sat, 22 Oct 2022 15:02:02 +0000 Original-Received: (at 58531) by debbugs.gnu.org; 22 Oct 2022 15:01:53 +0000 Original-Received: from localhost ([127.0.0.1]:42166 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omG0W-0001BC-GC for submit@debbugs.gnu.org; Sat, 22 Oct 2022 11:01:53 -0400 Original-Received: from mail-ed1-f43.google.com ([209.85.208.43]:38695) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1omG0S-0001Ay-Iy for 58531@debbugs.gnu.org; Sat, 22 Oct 2022 11:01:51 -0400 Original-Received: by mail-ed1-f43.google.com with SMTP id l22so16074270edj.5 for <58531@debbugs.gnu.org>; Sat, 22 Oct 2022 08:01:48 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=tcd.ie; s=google21; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:from:to:cc:subject:date:message-id:reply-to; bh=SQZXmqUwxKvnBuqmnKKcWionMSsnXOkRhtOkKDoVdrI=; b=PVOfQ5yyq0Ob3tSRYzjFFwMNpyXeqj2HkTwyWKAUs2K7NjQc5n64lk8KjQKa4a0D0F Z7ljfXMiXshMqTiSZDPvCd8prZKnlCv8MRq2fs6y7B1UOBm6WTrH8tso1gYnxJkpn+Jc PJFw0m8R+JtMvHEZT5LwLM1ED4A2y5gnkS6JWI2eYTUsog9sEhfhcai19lxWF9gTzoPH tvRXd6R5EM9P65tqr3dDazVDNfmNtdkkCWRhKWw/obnM7BNc0oR7I2rLvPO+ovPCtF5V hIIvGjvZRKbnb074liJhmo7r/NKJx0PHWO5pJsHfSEKXCHsZpCP3+AM8J193tEOSq+U7 /oTw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=mime-version:user-agent:message-id:date:references:in-reply-to :subject:cc:to:from:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=SQZXmqUwxKvnBuqmnKKcWionMSsnXOkRhtOkKDoVdrI=; b=iscoN6JVh9hYPJbljmmIJ4ejUQtdQgRTrmuXPYzD10seBL35nSDZaRxYLDPB3gcEqb yT+ySMaU5YOgxmY7mCjyqMB8VRqQa8QABXFYzZoOOdCSFKTOOG+5+3bPvE6FLUv8a5BE x7QhpLyxezl0CenAA+uNxxuqSOktX8j42f3IxQFFBu1T6iEJI17u5RZ1hZMdpO6jZq1u pl4c934LlwzbP+0LErpJXvIuPOpeT2Ur5+ehd/MDeY9ghKVfnFW0VXmgIB/hhJJxd3EE 9kOUZC952foyH/IQp17cpKPlygKK9aUosP5Y9EUrV4cg52l3iHP9vfYJNE1rzuW29Jri fQPw== X-Gm-Message-State: ACrzQf3KwXku6q2I49oVNEVpGtWjV9/cHq5sFnHBrDe8gKeZQXQns0bC fmH2vDcYz5N1aIlrSF6FVBhqw/89pvFfvQ== X-Google-Smtp-Source: AMsMyM5nZdcRVuncY/IqxvjZwEXW6GwyPJCB8+jBgl8jTR2LE9a/iV2IxRiUecZEJPsYWUBR65645A== X-Received: by 2002:a17:907:744:b0:741:36b9:d2cc with SMTP id xc4-20020a170907074400b0074136b9d2ccmr19416352ejb.613.1666450902575; Sat, 22 Oct 2022 08:01:42 -0700 (PDT) Original-Received: from localhost ([2a02:587:321f:7e8a:d9:365a:ced1:b3d1]) by smtp.gmail.com with ESMTPSA id l20-20020a056402231400b00457c5637578sm15002170eda.63.2022.10.22.08.01.40 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 22 Oct 2022 08:01:41 -0700 (PDT) In-Reply-To: (Stefan Monnier's message of "Sun, 16 Oct 2022 12:06:17 -0400") 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" Xref: news.gmane.io gmane.emacs.bugs:246039 Archived-At: --=-=-= Content-Type: text/plain Stefan Monnier [2022-10-16 12:06 -0400] wrote: >> Updated patch attached. > LGTM, feel free to push, thanks, WDYT of the attached additions now that bug#58563 is mostly addressed? Thanks, -- Basil --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0002-Replace-remaining-map-dispatch-with-cl-defmethod.patch >From 21d8e5fd49043b1cb75691e2e2bad3cf6c37c192 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 22 Oct 2022 16:54:19 +0300 Subject: [PATCH 2/2] Replace remaining map--dispatch with cl-defmethod * lisp/emacs-lisp/map.el (map--dispatch): Remove. (map--restore-advertised-signature): New convenience function. (map-elt, map-contains-key, map-put!): Break out map--dispatch clauses into corresponding cl-defmethods. Ensure original advertised-calling-convention is restored after them in older Emacs versions. (map--put): Group definition in file together with that of map-put!. * test/lisp/emacs-lisp/map-tests.el (test-map-elt-signature) (test-map-put!-signature, test-map-contains-key-signature): New tests for the assurances above. --- lisp/emacs-lisp/map.el | 138 +++++++++++++++++------------- test/lisp/emacs-lisp/map-tests.el | 19 ++++ 2 files changed, 96 insertions(+), 61 deletions(-) diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 29c94bf1fb..edcb93f3cf 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -80,25 +80,31 @@ map-let `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) ,@body)) -(eval-when-compile - (defmacro map--dispatch (map-var &rest args) - "Evaluate one of the forms specified by ARGS based on the type of MAP-VAR. - -The following keyword types are meaningful: `:list', -`:hash-table' and `:array'. - -An error is thrown if MAP-VAR is neither a list, hash-table nor array. - -Returns the result of evaluating the form associated with MAP-VAR's type." - (declare (debug t) (indent 1)) - `(cond ((listp ,map-var) ,(plist-get args :list)) - ((hash-table-p ,map-var) ,(plist-get args :hash-table)) - ((arrayp ,map-var) ,(plist-get args :array)) - (t (error "Unsupported map type `%S': %S" - (type-of ,map-var) ,map-var))))) - (define-error 'map-not-inplace "Cannot modify map in-place") +(defun map--restore-advertised-signature (function signature when) + "Restore FUNCTION symbol's advertised SIGNATURE if necessary. +This should be called after the last `cl-defmethod' of a +`cl-defgeneric' that declares an `advertised-calling-convention', +to work around bug#58563. +The problem is that each `cl-defmethod' overwrites the function +and prior to Emacs 29 discarded any existing advertised +signature. This workaround does not prevent third-party +`cl-defmethod's from discarding the advertised signature, but +it's better than nothing. +SIGNATURE should be the same as that originally declared, even if +this is not always enforced." + (let* ((fn (symbol-function function)) + (osig (if (eval-when-compile + (fboundp 'get-advertised-calling-convention)) + (get-advertised-calling-convention fn) + (gethash fn advertised-signature-table t)))) + (if (listp osig) + (cl-assert (equal osig signature) t + (format "Tried changing %s signature from %%s to %%s" + function)) + (set-advertised-calling-convention function signature when)))) + (defsubst map--plist-p (list) "Return non-nil if LIST is the start of a nonempty plist map." (and (consp list) (atom (car list)))) @@ -163,6 +169,9 @@ map-elt In the base definition, MAP can be an alist, plist, hash-table, or array." (declare + ;; `testfn' is deprecated. Sync this with the + ;; `map--restore-advertised-signature' below. + (advertised-calling-convention (map key &optional default) "27.1") (gv-expander (lambda (do) (gv-letplace (mgetter msetter) `(gv-delay-error ,map) @@ -181,20 +190,24 @@ map-elt ,(funcall msetter `(map-insert ,mgetter ,key ,v)) ;; Always return the value. - ,v))))))))) - ;; `testfn' is deprecated. - (advertised-calling-convention (map key &optional default) "27.1")) - ;; Can't use `cl-defmethod' with `advertised-calling-convention' - ;; (bug#58563). - (map--dispatch map - :list (if (map--plist-p map) - (let ((res (map--plist-member map key testfn))) - (if res (cadr res) default)) - (alist-get key map default nil (or testfn #'equal))) - :hash-table (gethash key map default) - :array (if (map-contains-key map key) - (aref map key) - default))) + ,v))))))))))) + +(cl-defmethod map-elt ((map list) key &optional default testfn) + (if (map--plist-p map) + (let ((res (map--plist-member map key testfn))) + (if res (cadr res) default)) + (alist-get key map default nil (or testfn #'equal)))) + +(cl-defmethod map-elt ((map hash-table) key &optional default _testfn) + (gethash key map default)) + +(cl-defmethod map-elt ((map array) key &optional default _testfn) + (if (map-contains-key map key) + (aref map key) + default)) + +;; This can be removed once we assume Emacs 29 or later. +(map--restore-advertised-signature 'map-elt '(map key &optional default) "27.1") (defmacro map-put (map key value &optional testfn) "Associate KEY with VALUE in MAP and return VALUE. @@ -388,10 +401,12 @@ map-contains-key ;; FIXME: The test function to use generally depends on the map object, ;; so specifying `testfn' here is problematic: e.g. for hash-tables ;; we shouldn't use `gethash' unless `testfn' is the same as the map's own - ;; test function! See also below for `advertised-calling-convention'. + ;; test function! "Return non-nil if and only if MAP contains KEY. TESTFN is deprecated. Its default depends on MAP. The default implementation delegates to `map-some'." + ;; Sync this with the `map--restore-advertised-signature' below. + (declare (advertised-calling-convention (map key) "27.1")) (unless testfn (setq testfn #'equal)) (map-some (lambda (k _v) (funcall testfn key k)) map)) @@ -413,11 +428,8 @@ map-contains-key (let ((v '(nil))) (not (eq v (gethash key map v))))) -;; FIXME: This comes after all the `cl-defmethod's because they -;; overwrite the function, and the `advertised-calling-convention' is -;; lost. We can't prevent third-party `cl-defmethod's from having the -;; same effect, but it's better than nothing (bug#58531#25, bug#58563). -(set-advertised-calling-convention 'map-contains-key '(map key) "27.1") +;; This can be removed once we assume Emacs 29 or later. +(map--restore-advertised-signature 'map-contains-key '(map key) "27.1") (cl-defgeneric map-some (pred map) "Return the first non-nil (PRED key val) in MAP. @@ -519,25 +531,34 @@ map-put! If it cannot do that, it signals a `map-not-inplace' error. To insert an element without modifying MAP, use `map-insert'." ;; `testfn' only exists for backward compatibility with `map-put'! - (declare (advertised-calling-convention (map key value) "27.1")) - ;; Can't use `cl-defmethod' with `advertised-calling-convention' - ;; (bug#58563). - (map--dispatch - map - :list - (progn - (if (map--plist-p map) - (map--plist-put map key value testfn) - (let ((oldmap map)) - (setf (alist-get key map key nil (or testfn #'equal)) value) - (unless (eq oldmap map) - (signal 'map-not-inplace (list oldmap))))) - ;; Always return the value. - value) - :hash-table (puthash key value map) - ;; FIXME: If `key' is too large, should we signal `map-not-inplace' - ;; and let `map-insert' grow the array? - :array (aset map key value))) + ;; Sync this with the `map--restore-advertised-signature' below. + (declare (advertised-calling-convention (map key value) "27.1"))) + +(cl-defmethod map-put! ((map list) key value &optional testfn) + (if (map--plist-p map) + (map--plist-put map key value testfn) + (let ((oldmap map)) + (setf (alist-get key map key nil (or testfn #'equal)) value) + (unless (eq oldmap map) + (signal 'map-not-inplace (list oldmap))))) + ;; Always return the value. + value) + +(cl-defmethod map-put! ((map hash-table) key value &optional _testfn) + (puthash key value map)) + +(cl-defmethod map-put! ((map array) key value &optional _testfn) + ;; FIXME: If `key' is too large, should we signal `map-not-inplace' + ;; and let `map-insert' grow the array? + (aset map key value)) + +;; This can be removed once we assume Emacs 29 or later. +(map--restore-advertised-signature 'map-put! '(map key value) "27.1") + +;; There shouldn't be old source code referring to `map--put', yet we do +;; need to keep it for backward compatibility with .elc files where the +;; expansion of `setf' may call this function. +(define-obsolete-function-alias 'map--put #'map-put! "27.1") (cl-defgeneric map-insert (map key value) "Return a new map like MAP except that it associates KEY with VALUE. @@ -554,11 +575,6 @@ map-insert (cons key (cons value map)) (cons (cons key value) map))) -;; There shouldn't be old source code referring to `map--put', yet we do -;; need to keep it for backward compatibility with .elc files where the -;; expansion of `setf' may call this function. -(define-obsolete-function-alias 'map--put #'map-put! "27.1") - (cl-defmethod map-apply (function (map list)) (if (map--plist-p map) (cl-call-next-method) diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 8cc76612ab..75ebe59431 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -171,6 +171,12 @@ test-map-elt-gv (ert-deftest test-map-elt-with-nil-value () (should-not (map-elt '((a . 1) (b)) 'b 2))) +(ert-deftest test-map-elt-signature () + "Test that `map-elt' has the right advertised signature. +See bug#58531#25 and bug#58563." + (should (equal (get-advertised-calling-convention (symbol-function 'map-elt)) + '(map key &optional default)))) + (ert-deftest test-map-put! () (with-maps-do map (setf (map-elt map 2) 'hello) @@ -231,6 +237,12 @@ test-map-put!-plist (map-put! map 'a -3 #'string=)) (should (equal map '("a" -3 a 2))))) +(ert-deftest test-map-put!-signature () + "Test that `map-put!' has the right advertised signature. +See bug#58531#25 and bug#58563." + (should (equal (get-advertised-calling-convention (symbol-function 'map-put!)) + '(map key value)))) + (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." (let ((alist (list (cons 0 'a)))) @@ -492,6 +504,13 @@ test-map-contains-key-testfn (should-not (map-contains-key alist key #'eq)) (should-not (map-contains-key plist key #'eq)))) +(ert-deftest test-map-contains-key-signature () + "Test that `map-contains-key' has the right advertised signature. +See bug#58531#25 and bug#58563." + (should (equal (get-advertised-calling-convention + (symbol-function 'map-contains-key)) + '(map key)))) + (ert-deftest test-map-some () (with-maps-do map (should (eq (map-some (lambda (k _v) (and (= k 1) 'found)) map) -- 2.35.1 --=-=-=--