Add an optional testfn parameter to assoc

* src/fns.c (assoc): New optional testfn parameter used for comparison
when provided.
* test/src/fns-tests.el (test-assoc-testfn): Add tests for the new
'testfn' parameter.
* src/buffer.c:
* src/coding.c:
* src/dbusbind.c:
* src/font.c:
* src/fontset.c:
* src/gfilenotify.c:
* src/image.c:
* src/keymap.c:
* src/process.c:
* src/w32fns.c:
* src/w32font.c:
* src/w32notify.c:
* src/w32term.c:
* src/xdisp.c:
* src/xfont.c: Add a third argument to Fassoc calls.
* etc/NEWS:
* doc/lispref/lists.texi: Document the new 'testfn' parameter.

19 files changed, 53 insertions, 36 deletions

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 8eab2818f97..966d8f18b17 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1511,12 +1511,12 @@ respects.  A property list behaves like an association list in which
 each key can occur only once.  @xref{Property Lists}, for a comparison
 of property lists and association lists.
 
-@defun assoc key alist
+@defun assoc key alist &optional testfn
 This function returns the first association for @var{key} in
 @var{alist}, comparing @var{key} against the alist elements using
-@code{equal} (@pxref{Equality Predicates}).  It returns @code{nil} if no
-association in @var{alist} has a @sc{car} @code{equal} to @var{key}.
-For example:
+@var{testfn} if non-nil, or @code{equal} if nil (@pxref{Equality
+Predicates}).  It returns @code{nil} if no association in @var{alist}
+has a @sc{car} equal to @var{key}.  For example:
 
 @smallexample
 (setq trees '((pine . cones) (oak . acorns) (maple . seeds)))
@@ -1561,11 +1561,11 @@ this as reverse @code{assoc}, finding the key for a given value.
 @defun assq key alist
 This function is like @code{assoc} in that it returns the first
 association for @var{key} in @var{alist}, but it makes the comparison
-using @code{eq} instead of @code{equal}.  @code{assq} returns @code{nil}
-if no association in @var{alist} has a @sc{car} @code{eq} to @var{key}.
-This function is used more often than @code{assoc}, since @code{eq} is
-faster than @code{equal} and most alists use symbols as keys.
-@xref{Equality Predicates}.
+using @code{eq}.  @code{assq} returns @code{nil} if no association in
+@var{alist} has a @sc{car} @code{eq} to @var{key}.  This function is
+used more often than @code{assoc}, since @code{eq} is faster than
+@code{equal} and most alists use symbols as keys.  @xref{Equality
+Predicates}.
 
 @smallexample
 (setq trees '((pine . cones) (oak . acorns) (maple . seeds)))
diff --git a/etc/NEWS b/etc/NEWS
index a00760c2f8e..68ebdb3c15c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -100,6 +100,11 @@ required capabilities are found in terminfo.  See the FAQ node
 
 * Changes in Emacs 26.1
 
++++
+** The function 'assoc' now takes an optional third argument 'testfn'.
+This argument, when non-nil, is used for comparison instead of
+'equal'.
+
 ** The variable 'emacs-version' no longer includes the build number.
 This is now stored separately in a new variable, 'emacs-build-number'.
 
diff --git a/src/buffer.c b/src/buffer.c
index 780e4d7a7d6..e0972aac33c 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -1164,7 +1164,7 @@ buffer_local_value (Lisp_Object variable, Lisp_Object buffer)
       { /* Look in local_var_alist.  */
         struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
         XSETSYMBOL (variable, sym); /* Update In case of aliasing.  */
-        result = Fassoc (variable, BVAR (buf, local_var_alist));
+        result = Fassoc (variable, BVAR (buf, local_var_alist), Qnil);
         if (!NILP (result))
           {
             if (blv->fwd)
diff --git a/src/coding.c b/src/coding.c
index 5682fc015ad..50ad206be69 100644
--- a/src/coding.c
+++ b/src/coding.c
@@ -10539,7 +10539,7 @@ usage: (define-coding-system-internal ...)  */)
           ASET (this_spec, 2, this_eol_type);
           Fputhash (this_name, this_spec, Vcoding_system_hash_table);
           Vcoding_system_list = Fcons (this_name, Vcoding_system_list);
-          val = Fassoc (Fsymbol_name (this_name), Vcoding_system_alist);
+          val = Fassoc (Fsymbol_name (this_name), Vcoding_system_alist, Qnil);
           if (NILP (val))
             Vcoding_system_alist
               = Fcons (Fcons (Fsymbol_name (this_name), Qnil),
@@ -10554,7 +10554,7 @@ usage: (define-coding-system-internal ...)  */)
 
   Fputhash (name, spec_vec, Vcoding_system_hash_table);
   Vcoding_system_list = Fcons (name, Vcoding_system_list);
-  val = Fassoc (Fsymbol_name (name), Vcoding_system_alist);
+  val = Fassoc (Fsymbol_name (name), Vcoding_system_alist, Qnil);
   if (NILP (val))
     Vcoding_system_alist = Fcons (Fcons (Fsymbol_name (name), Qnil),
                                   Vcoding_system_alist);
@@ -10662,7 +10662,7 @@ DEFUN ("define-coding-system-alias", Fdefine_coding_system_alias,
 
   Fputhash (alias, spec, Vcoding_system_hash_table);
   Vcoding_system_list = Fcons (alias, Vcoding_system_list);
-  val = Fassoc (Fsymbol_name (alias), Vcoding_system_alist);
+  val = Fassoc (Fsymbol_name (alias), Vcoding_system_alist, Qnil);
   if (NILP (val))
     Vcoding_system_alist = Fcons (Fcons (Fsymbol_name (alias), Qnil),
                                   Vcoding_system_alist);
diff --git a/src/dbusbind.c b/src/dbusbind.c
index d2460fd886e..0d9d3e514fd 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -955,7 +955,7 @@ xd_get_connection_address (Lisp_Object bus)
   DBusConnection *connection;
   Lisp_Object val;
 
-  val = CDR_SAFE (Fassoc (bus, xd_registered_buses));
+  val = CDR_SAFE (Fassoc (bus, xd_registered_buses, Qnil));
   if (NILP (val))
     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
   else
@@ -1057,7 +1057,7 @@ xd_close_bus (Lisp_Object bus)
   Lisp_Object busobj;
 
   /* Check whether we are connected.  */
-  val = Fassoc (bus, xd_registered_buses);
+  val = Fassoc (bus, xd_registered_buses, Qnil);
   if (NILP (val))
     return;
 
@@ -1127,7 +1127,7 @@ this connection to those buses.  */)
   xd_close_bus (bus);
 
   /* Check, whether we are still connected.  */
-  val = Fassoc (bus, xd_registered_buses);
+  val = Fassoc (bus, xd_registered_buses, Qnil);
   if (!NILP (val))
     {
       connection = xd_get_connection_address (bus);
diff --git a/src/fns.c b/src/fns.c
index 6610d2a6d0e..f0e10e311f5 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -1417,17 +1417,22 @@ assq_no_quit (Lisp_Object key, Lisp_Object list)
   return Qnil;
 }
 
-DEFUN ("assoc", Fassoc, Sassoc, 2, 2, 0,
-       doc: /* Return non-nil if KEY is `equal' to the car of an element of LIST.
-The value is actually the first element of LIST whose car equals KEY.  */)
-  (Lisp_Object key, Lisp_Object list)
+DEFUN ("assoc", Fassoc, Sassoc, 2, 3, 0,
+       doc: /* Return non-nil if KEY is equal to the car of an element of LIST.
+The value is actually the first element of LIST whose car equals KEY.
+
+Equality is defined by TESTFN if non-nil or by `equal' if nil.  */)
+     (Lisp_Object key, Lisp_Object list, Lisp_Object testfn)
 {
   Lisp_Object tail = list;
   FOR_EACH_TAIL (tail)
     {
       Lisp_Object car = XCAR (tail);
       if (CONSP (car)
-          && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key))))
+          && (NILP (testfn)
+              ? (EQ (XCAR (car), key) || !NILP (Fequal
+                                                (XCAR (car), key)))
+              : !NILP (call2 (testfn, XCAR (car), key))))
         return car;
     }
   CHECK_LIST_END (tail, list);
diff --git a/src/font.c b/src/font.c
index 5a3f271ef85..a5e5b6a5b9d 100644
--- a/src/font.c
+++ b/src/font.c
@@ -1893,7 +1893,7 @@ otf_tag_symbol (OTF_Tag tag)
 static OTF *
 otf_open (Lisp_Object file)
 {
-  Lisp_Object val = Fassoc (file, otf_list);
+  Lisp_Object val = Fassoc (file, otf_list, Qnil);
   OTF *otf;
 
   if (! NILP (val))
diff --git a/src/fontset.c b/src/fontset.c
index 850558b08a0..74018060b85 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -1186,7 +1186,7 @@ fs_query_fontset (Lisp_Object name, int name_pattern)
     {
       tem = Frassoc (name, Vfontset_alias_alist);
       if (NILP (tem))
-        tem = Fassoc (name, Vfontset_alias_alist);
+        tem = Fassoc (name, Vfontset_alias_alist, Qnil);
       if (CONSP (tem) && STRINGP (XCAR (tem)))
         name = XCAR (tem);
       else if (name_pattern == 0)
diff --git a/src/gfilenotify.c b/src/gfilenotify.c
index 285a253733d..fa4854c664d 100644
--- a/src/gfilenotify.c
+++ b/src/gfilenotify.c
@@ -266,7 +266,7 @@ reason.  Removing the watch by calling `gfile-rm-watch' also makes it
 invalid.  */)
      (Lisp_Object watch_descriptor)
 {
-  Lisp_Object watch_object = Fassoc (watch_descriptor, watch_list);
+  Lisp_Object watch_object = Fassoc (watch_descriptor, watch_list, Qnil);
   if (NILP (watch_object))
     return Qnil;
   else
diff --git a/src/image.c b/src/image.c
index 91749fb8733..1426e309445 100644
--- a/src/image.c
+++ b/src/image.c
@@ -4231,7 +4231,7 @@ xpm_load_image (struct frame *f,
       color_val = Qnil;
       if (!NILP (color_symbols) && !NILP (symbol_color))
         {
-          Lisp_Object specified_color = Fassoc (symbol_color, color_symbols);
+          Lisp_Object specified_color = Fassoc (symbol_color, color_symbols, Qnil);
 
           if (CONSP (specified_color) && STRINGP (XCDR (specified_color)))
             {
diff --git a/src/keymap.c b/src/keymap.c
index b568f47cba7..db9aa7cbf38 100644
--- a/src/keymap.c
+++ b/src/keymap.c
@@ -1292,7 +1292,7 @@ silly_event_symbol_error (Lisp_Object c)
   base = XCAR (parsed);
   name = Fsymbol_name (base);
   /* This alist includes elements such as ("RET" . "\\r").  */
-  assoc = Fassoc (name, exclude_keys);
+  assoc = Fassoc (name, exclude_keys, Qnil);
 
   if (! NILP (assoc))
     {
diff --git a/src/process.c b/src/process.c
index abd017bb907..19009515336 100644
--- a/src/process.c
+++ b/src/process.c
@@ -951,7 +951,7 @@ DEFUN ("get-process", Fget_process, Sget_process, 1, 1, 0,
   if (PROCESSP (name))
     return name;
   CHECK_STRING (name);
-  return Fcdr (Fassoc (name, Vprocess_alist));
+  return Fcdr (Fassoc (name, Vprocess_alist, Qnil));
 }
 
 /* This is how commands for the user decode process arguments.  It
diff --git a/src/w32fns.c b/src/w32fns.c
index b0842b5ee6c..457599fce0e 100644
--- a/src/w32fns.c
+++ b/src/w32fns.c
@@ -467,7 +467,7 @@ if the entry is new.  */)
   block_input ();
 
   /* replace existing entry in w32-color-map or add new entry. */
-  entry = Fassoc (name, Vw32_color_map);
+  entry = Fassoc (name, Vw32_color_map, Qnil);
   if (NILP (entry))
     {
       entry = Fcons (name, rgb);
diff --git a/src/w32font.c b/src/w32font.c
index 67d2f6d666d..314d7acdcc6 100644
--- a/src/w32font.c
+++ b/src/w32font.c
@@ -1627,7 +1627,7 @@ x_to_w32_charset (char * lpcs)
      Format of each entry is
        (CHARSET_NAME . (WINDOWS_CHARSET . CODEPAGE)).
   */
-  this_entry = Fassoc (build_string (charset), Vw32_charset_info_alist);
+  this_entry = Fassoc (build_string (charset), Vw32_charset_info_alist, Qnil);
 
   if (NILP (this_entry))
     {
diff --git a/src/w32notify.c b/src/w32notify.c
index 25205816bae..e8bdef8bdd3 100644
--- a/src/w32notify.c
+++ b/src/w32notify.c
@@ -642,7 +642,7 @@ WATCH-DESCRIPTOR should be an object returned by `w32notify-add-watch'.  */)
   /* Remove the watch object from watch list.  Do this before freeing
      the object, do that even if we fail to free it, watch_list is
      kept free of junk.  */
-  watch_object = Fassoc (watch_descriptor, watch_list);
+  watch_object = Fassoc (watch_descriptor, watch_list, Qnil);
   if (!NILP (watch_object))
     {
       watch_list = Fdelete (watch_object, watch_list);
@@ -679,7 +679,7 @@ the watcher thread exits abnormally for any other reason.  Removing the
 watch by calling `w32notify-rm-watch' also makes it invalid.  */)
      (Lisp_Object watch_descriptor)
 {
-  Lisp_Object watch_object = Fassoc (watch_descriptor, watch_list);
+  Lisp_Object watch_object = Fassoc (watch_descriptor, watch_list, Qnil);
 
   if (!NILP (watch_object))
     {
diff --git a/src/w32term.c b/src/w32term.c
index c37805cb6ca..0f7bb9337f6 100644
--- a/src/w32term.c
+++ b/src/w32term.c
@@ -6110,7 +6110,7 @@ x_calc_absolute_position (struct frame *f)
 
           list = CDR(list);
 
-          geometry = Fassoc (Qgeometry, attributes);
+          geometry = Fassoc (Qgeometry, attributes, Qnil);
           if (!NILP (geometry))
             {
               monitor_left = Fnth (make_number (1), geometry);
diff --git a/src/xdisp.c b/src/xdisp.c
index 28ed7685236..abca6a8137a 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -23314,7 +23314,7 @@ display_mode_element (struct it *it, int depth, int field_width, int precision,
                     props = oprops;
                   }
 
-                aelt = Fassoc (elt, mode_line_proptrans_alist);
+                aelt = Fassoc (elt, mode_line_proptrans_alist, Qnil);
                 if (! NILP (aelt) && !NILP (Fequal (props, XCDR (aelt))))
                   {
                     /* AELT is what we want.  Move it to the front
@@ -28788,7 +28788,7 @@ set_frame_cursor_types (struct frame *f, Lisp_Object arg)
 
   /* By default, set up the blink-off state depending on the on-state.  */
 
-  tem = Fassoc (arg, Vblink_cursor_alist);
+  tem = Fassoc (arg, Vblink_cursor_alist, Qnil);
   if (!NILP (tem))
     {
       FRAME_BLINK_OFF_CURSOR (f)
@@ -28926,7 +28926,7 @@ get_window_cursor_type (struct window *w, struct glyph *glyph, int *width,
   /* Cursor is blinked off, so determine how to "toggle" it.  */
 
   /* First look for an entry matching the buffer's cursor-type in blink-cursor-alist.  */
-  if ((alt_cursor = Fassoc (BVAR (b, cursor_type), Vblink_cursor_alist), !NILP (alt_cursor)))
+  if ((alt_cursor = Fassoc (BVAR (b, cursor_type), Vblink_cursor_alist, Qnil), !NILP (alt_cursor)))
     return get_specified_cursor_type (XCDR (alt_cursor), width);
 
   /* Then see if frame has specified a specific blink off cursor type.  */
diff --git a/src/xfont.c b/src/xfont.c
index b73596ce7ce..85fccf0dafd 100644
--- a/src/xfont.c
+++ b/src/xfont.c
@@ -505,7 +505,8 @@ xfont_list (struct frame *f, Lisp_Object spec)
       Lisp_Object alter;
 
       if ((alter = Fassoc (SYMBOL_NAME (registry),
-                           Vface_alternative_font_registry_alist),
+                           Vface_alternative_font_registry_alist,
+                           Qnil),
            CONSP (alter)))
         {
           /* Pointer to REGISTRY-ENCODING field.  */
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 2e463455f0c..e294859226c 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -373,6 +373,12 @@
     (should-error (assoc 3 d1) :type 'wrong-type-argument)
     (should-error (assoc 3 d2) :type 'wrong-type-argument)))
 
+(ert-deftest test-assoc-testfn ()
+  (let ((alist '(("a" . 1) ("b" . 2))))
+    (should-not (assoc "a" alist #'ignore))
+    (should (eq (assoc "b" alist #'string-equal) (cadr alist)))
+    (should-not (assoc "b" alist #'eq))))
+
 (ert-deftest test-cycle-rassq ()
   (let ((c1 (cyc1 '(0 . 1)))
         (c2 (cyc2 '(0 . 1) '(0 . 2)))