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

[Nicolas Petton]

Stefan Monnier <monnier@IRO.UMontreal.CA> writes:

> It's like "faire d'une pierre deux coups", which you could also relate
> to "buy one get one free".  So, yes, it's a good thing to kill two birds
> in a shot.

Now that I know it's a good things to kill birds, what about the patch
below, and then applyind a modified version of your patch, Tino?


From 0ac5e42962fde069680fefeddc3ab589fe4b6d6c Mon Sep 17 00:00:00 2001
From: Nicolas Petton <nicolas@petton.fr>
Date: Fri, 7 Jul 2017 21:21:55 +0200
Subject: [PATCH] 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.
---
 doc/lispref/lists.texi | 18 +++++++++---------
 etc/NEWS               |  5 +++++
 src/buffer.c           |  2 +-
 src/coding.c           |  6 +++---
 src/dbusbind.c         |  6 +++---
 src/fns.c              | 23 ++++++++++++++++-------
 src/font.c             |  2 +-
 src/fontset.c          |  2 +-
 src/gfilenotify.c      |  2 +-
 src/image.c            |  2 +-
 src/keymap.c           |  2 +-
 src/process.c          |  2 +-
 src/w32fns.c           |  2 +-
 src/w32font.c          |  2 +-
 src/w32notify.c        |  4 ++--
 src/w32term.c          |  2 +-
 src/xdisp.c            |  6 +++---
 src/xfont.c            |  3 ++-
 test/src/fns-tests.el  |  6 ++++++
 19 files changed, 59 insertions(+), 38 deletions(-)

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 8eab281..966d8f1 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1511,12 +1511,12 @@ Association Lists
 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 @@ Association Lists
 @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 13805ce..d7a6f29 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 80dbd33..bf49d61 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 5682fc0..50ad206 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 d2460fd..0d9d3e5 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 6610d2a..6f4fb87 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -1417,18 +1417,27 @@ 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))))
-       return car;
+      if (NILP (testfn))
+       {
+         if (CONSP (car)
+             && (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key))))
+           return car;
+       }
+      else if (CONSP (car) && (!NILP (call2 (testfn, (XCAR (car)), key))))
+       {
+         return car;
+       }
     }
   CHECK_LIST_END (tail, list);
   return Qnil;
diff --git a/src/font.c b/src/font.c
index 5a3f271..a5e5b6a 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 850558b..7401806 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 285a253..fa4854c 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 91749fb..1426e30 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 b568f47..db9aa7c 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 abd017b..1900951 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 b0842b5..457599f 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 67d2f6d..314d7ac 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 2520581..e8bdef8 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 c37805c..0f7bb93 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 1c316fa..6717405 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -22859,7 +22859,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
@@ -28325,7 +28325,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)
@@ -28463,7 +28463,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 b73596c..85fccf0 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 2e46345..e294859 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -373,6 +373,12 @@ dot2
     (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)))
-- 
2.9.4

signature.asc
Description: PGP signature