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.

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 8eab2818f976fa752bb28f565b5b0d5eef24e242..966d8f18b17b29e6c79e3574a0dacf3d1a2fc2d6 100644 (file)
--- 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 a00760c2f8e212f091a65b06140d52165aa28075..68ebdb3c15c6530c878d8c4a616b09287303d961 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -100,6 +100,11 @@ required capabilities are found in terminfo.  See the FAQ node
 \f
 * 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 780e4d7a7d698c17899afaa987a13b5d7af7a1c7..e0972aac33c0428cf7f6bc2db6b8e92c91ec8262 100644 (file)
--- 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 5682fc015add63ff29fbaef81a22496b4f0dfefc..50ad206be698b846b355120866f9941769ceeb41 100644 (file)
--- 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 d2460fd886e3963e93aae52a420f000eef646970..0d9d3e514fd1439b3b80cf7d4dfe4ec6e57badac 100644 (file)
--- 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 6610d2a6d0e1e54cb9ebed9b03db666cb451cf97..f0e10e311f5a48d271dc3c24f724ed59601060d1 100644 (file)
--- 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 5a3f271ef855dc6fc848bccf8aa2564671ac1813..a5e5b6a5b9dc077f0eda09e732fece61d031cd1e 100644 (file)
--- 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 850558b08a0bb3dd50f77278225f2ae235a83aef..74018060b858291cf6e893174422654c4af3ad50 100644 (file)
--- 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 285a253733dfa45c8a084345eb7d6d993cfa79aa..fa4854c664d5080769f5508b1ab0e9c4772c2771 100644 (file)
--- 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 91749fb8733b9c9d79947455054951b3809ffe8e..1426e309445f4ae68e74bbac0e788c1a61f53802 100644 (file)
--- 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 b568f47cba71c4d32b753a62508c1309cfbc459a..db9aa7cbf38401c5eb3a77da064d0f5c9f777c10 100644 (file)
--- 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 abd017bb907bf3946ae7d1c438d3b1d0eb3c21af..19009515336b87dd6364e9310f43f7da769807ff 100644 (file)
--- 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 b0842b5ee6c7482f38b933db5401e2f9a16a2cbb..457599fce0e1935eb22702710740eeec4164e562 100644 (file)
--- 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 67d2f6d666d8ce9c6c7011274b53e830b580c92b..314d7acdcc6c41de1533593055ed24f42896113f 100644 (file)
--- 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 25205816bae275cf70cbf59485c0f0629601a797..e8bdef8bdd34b77d5f85403b5c34650e493d6ecc 100644 (file)
--- 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 c37805cb6ca7247db031ce2912a174d834e4e36c..0f7bb9337f6b2661386a305aae1b652f0e1f8ae4 100644 (file)
--- 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 28ed768523626ff63ff333845012ba953855250b..abca6a8137ab1fa018771bba3797735affcf1365 100644 (file)
--- 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 b73596ce7cef2f22936d6e93ee71254b5919b1ae..85fccf0dafdbb1746424a5f0e580928d8dc16f46 100644 (file)
--- 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 2e463455f0c825c4ab3600baad58aeaa2cadbffe..e294859226cac024fc30492304a6403f84c1a0ab 100644 (file)
--- 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)))