>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