bug#27584: 26.0.50; alist-get: Add optional arg TESTFN

[Tino Calancha]

Nicolas Petton <nicolas@petton.fr> writes:

> Tino, would you like to adapt your patch to use the new assoc?
Here we are:

--8<-----------------------------cut here---------------start------------->8---
commit 2a9fb44ddae0acbd09c3123f06981d291163e765
Author: Tino Calancha <tino.calancha@gmail.com>
Date:   Tue Jul 11 18:17:00 2017 +0900

    alist-get: Add optional arg TESTFN
    
    If TESTFN is non-nil, then it is the predicate to lookup
    the alist.  Otherwise, use 'eq' (Bug#27584).
    * lisp/subr.el (alist-get): Add optional arg FULL.
    * lisp/emacs-lisp/map.el (map-elt, map-put): Add optional arg TESTFN.
    * lisp/emacs-lisp/gv.el (alist-get): Update expander.
    * doc/lispref/lists.texi (Association Lists): Update manual.
    * etc/NEWS: Announce the changes.
    * test/lisp/emacs-lisp/map-tests.el (test-map-put-testfn-alist)
    (test-map-elt-testfn): New tests.

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 966d8f18b1..39353b6de6 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1589,16 +1589,20 @@ Association Lists
 @end smallexample
 @end defun
 
-@defun alist-get key alist &optional default remove
-This function is like @code{assq}, but instead of returning the entire
-association for @var{key} in @var{alist},
-@w{@code{(@var{key} . @var{value})}}, it returns just the @var{value}.
-If @var{key} is not found in @var{alist}, it returns @var{default}.
-
-This is a generalized variable (@pxref{Generalized Variables}) that
-can be used to change a value with @code{setf}.  When using it to set
-a value, optional argument @var{remove} non-@code{nil} means to remove
-@var{key} from @var{alist} if the new value is @code{eql} to @var{default}.
+@defun alist-get key alist &optional default remove testfn
+This function is similar to @code{assq}.  It finds the first
+association @w{@code{(@var{key} . @var{value})}} by comparing
+@var{key} with @var{alist} elements, and, if found, returns the
+@var{value} of that association.  If no association is found, the
+function returns @var{default}.  Comparison of @var{key} against
+@var{alist} elements uses the function specified by @var{testfn},
+defaulting to @code{eq}.
+
+The return value is a generalized variable (@pxref{Generalized
+Variables}) that can be used to change a value with @code{setf}.  When
+using it to set a value, optional argument @var{remove} non-@code{nil}
+means to remove @var{key}'s association from @var{alist} if the new
+value is @code{eql} to @var{default}.
 @end defun
 
 @defun rassq value alist
diff --git a/etc/NEWS b/etc/NEWS
index 68ebdb3c15..eb61e7d182 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1105,6 +1105,9 @@ break.
 
 * Lisp Changes in Emacs 26.1
 
++++
+** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'.
+
 ** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2
 contain the same elements, regardless of the order.
 
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index c5c12a6414..27376fc7f9 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -377,10 +377,12 @@ setf
     `(with-current-buffer ,buf (set (make-local-variable ,var) ,v))))
 
 (gv-define-expander alist-get
-  (lambda (do key alist &optional default remove)
+  (lambda (do key alist &optional default remove testfn)
     (macroexp-let2 macroexp-copyable-p k key
       (gv-letplace (getter setter) alist
-        (macroexp-let2 nil p `(assq ,k ,getter)
+        (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
+                                  (assoc ,k ,getter ,testfn)
+                                (assq ,k ,getter))
           (funcall do (if (null default) `(cdr ,p)
                         `(if ,p (cdr ,p) ,default))
                    (lambda (v)
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index a89457e877..31ba075c40 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -4,7 +4,7 @@
 
 ;; Author: Nicolas Petton <nicolas@petton.fr>
 ;; Keywords: convenience, map, hash-table, alist, array
-;; Version: 1.1
+;; Version: 1.2
 ;; Package: map
 
 ;; Maintainer: emacs-devel@gnu.org
@@ -93,11 +93,13 @@ map-let
            ((arrayp ,map-var) ,(plist-get args :array))
            (t (error "Unsupported map: %s" ,map-var)))))
 
-(defun map-elt (map key &optional default)
+(defun map-elt (map key &optional default testfn)
   "Lookup KEY in MAP and return its associated value.
 If KEY is not found, return DEFAULT which defaults to nil.
 
-If MAP is a list, `eql' is used to lookup KEY.
+If MAP is a list, `eql' is used to lookup KEY.  Optional argument
+TESTFN, if non-nil, means use its function definition instead of
+`eql'.
 
 MAP can be a list, hash-table or array."
   (declare
@@ -106,30 +108,33 @@ map-elt
       (gv-letplace (mgetter msetter) `(gv-delay-error ,map)
         (macroexp-let2* nil
             ;; Eval them once and for all in the right order.
-            ((key key) (default default))
+            ((key key) (default default) (testfn testfn))
           `(if (listp ,mgetter)
                ;; Special case the alist case, since it can't be handled by the
                ;; map--put function.
                ,(gv-get `(alist-get ,key (gv-synthetic-place
                                           ,mgetter ,msetter)
-                                    ,default)
+                                    ,default nil ,testfn)
                         do)
              ,(funcall do `(map-elt ,mgetter ,key ,default)
                        (lambda (v) `(map--put ,mgetter ,key ,v)))))))))
   (map--dispatch map
-    :list (alist-get key map default)
+    :list (alist-get key map default nil testfn)
     :hash-table (gethash key map default)
     :array (if (and (>= key 0) (< key (seq-length map)))
                (seq-elt map key)
              default)))
 
-(defmacro map-put (map key value)
+(defmacro map-put (map key value &optional testfn)
   "Associate KEY with VALUE in MAP and return VALUE.
 If KEY is already present in MAP, replace the associated value
 with VALUE.
+When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'.
+TESTFN, if non-nil, means use its function definition instead of
+`eql'.
 
 MAP can be a list, hash-table or array."
-  `(setf (map-elt ,map ,key) ,value))
+  `(setf (map-elt ,map ,key nil ,testfn) ,value))
 
 (defun map-delete (map key)
   "Delete KEY from MAP and return MAP.
diff --git a/lisp/subr.el b/lisp/subr.el
index a9edff6166..d9d918ed12 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -725,15 +725,18 @@ rassq-delete-all
        (setq tail tail-cdr))))
   alist)
 
-(defun alist-get (key alist &optional default remove)
-  "Return the value associated with KEY in ALIST, using `assq'.
+(defun alist-get (key alist &optional default remove testfn)
+  "Return the value associated with KEY in ALIST.
 If KEY is not found in ALIST, return DEFAULT.
+Use TESTFN to lookup in the alist if non-nil.  Otherwise, use `assq'.
 
 This is a generalized variable suitable for use with `setf'.
 When using it to set a value, optional argument REMOVE non-nil
 means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
   (ignore remove) ;;Silence byte-compiler.
-  (let ((x (assq key alist)))
+  (let ((x (if (not testfn)
+               (assq key alist)
+             (assoc key alist testfn))))
     (if x (cdr x) default)))
 
 (defun remove (elt seq)
diff --git a/test/lisp/emacs-lisp/map-tests.el 
b/test/lisp/emacs-lisp/map-tests.el
index 07e85cc539..15b0655040 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -63,6 +63,11 @@ with-maps-do
   (with-maps-do map
     (should (= 5 (map-elt map 7 5)))))
 
+(ert-deftest test-map-elt-testfn ()
+  (let ((map (list (cons "a" 1) (cons "b" 2))))
+    (should-not (map-elt map "a"))
+    (should (map-elt map "a" nil 'equal))))
+
 (ert-deftest test-map-elt-with-nil-value ()
   (should (null (map-elt '((a . 1)
                            (b))
@@ -94,6 +99,13 @@ with-maps-do
     (should (eq (map-elt alist 2)
                 'b))))
 
+(ert-deftest test-map-put-testfn-alist ()
+  (let ((alist (list (cons "a" 1) (cons "b" 2))))
+    (map-put alist "a" 3 'equal)
+    (should-not (cddr alist))
+    (map-put alist "a" 9)
+    (should (cddr alist))))
+
 (ert-deftest test-map-put-return-value ()
   (let ((ht (make-hash-table)))
     (should (eq (map-put ht 'a 'hello) 'hello))))
--8<-----------------------------cut here---------------end--------------->8---
In GNU Emacs 26.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.22.11)
 of 2017-07-11
Repository revision: 0bece6c6815cc59e181817a2765a4ea752f34f56