bug#58531: 29.0.50; Wrong predicate used by map-elt gv getter

["Basil L. Contovounesios" via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>]

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

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


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0002-Replace-remaining-map-dispatch-with-cl-defmethod.patch --]
[-- Type: text/x-diff, Size: 11157 bytes --]

From 21d8e5fd49043b1cb75691e2e2bad3cf6c37c192 Mon Sep 17 00:00:00 2001
From: "Basil L. Contovounesios" <contovob@tcd.ie>
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