From: Nicolas Petton <nicolas@petton.fr>
To: Stefan Monnier <monnier@IRO.UMontreal.CA>
Cc: 27584@debbugs.gnu.org, Tino Calancha <tino.calancha@gmail.com>
Subject: bug#27584: 26.0.50; alist-get: Add optional arg TESTFN
Date: Fri, 07 Jul 2017 21:47:03 +0200 [thread overview]
Message-ID: <8737a858so.fsf@petton.fr> (raw)
In-Reply-To: <jwvmv8gnt99.fsf-monnier+emacsbugs@gnu.org>
[-- Attachment #1: Type: text/plain, Size: 16139 bytes --]
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
\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 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
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 472 bytes --]
next prev parent reply other threads:[~2017-07-07 19:47 UTC|newest]
Thread overview: 48+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-07-05 3:22 bug#27584: 26.0.50; alist-get: Add optional arg TESTFN Tino Calancha
2017-07-05 8:53 ` Tino Calancha
2017-07-05 9:19 ` Nicolas Petton
2017-07-05 13:18 ` Tino Calancha
2017-07-06 6:05 ` Tino Calancha
2017-07-06 6:13 ` Stefan Monnier
2017-07-06 6:20 ` Tino Calancha
2017-07-06 9:36 ` Nicolas Petton
2017-07-06 10:55 ` Tino Calancha
2017-07-06 11:06 ` Nicolas Petton
2017-07-06 15:07 ` Stefan Monnier
2017-07-07 6:48 ` Tino Calancha
2017-07-07 7:46 ` Eli Zaretskii
2017-07-07 8:09 ` Nicolas Petton
2017-07-07 15:53 ` Stefan Monnier
2017-07-09 14:45 ` Tino Calancha
2017-07-10 12:04 ` Michael Heerdegen
2017-07-10 12:28 ` Tino Calancha
2017-07-10 12:38 ` Michael Heerdegen
2017-07-10 12:47 ` Michael Heerdegen
2017-07-10 13:02 ` Tino Calancha
2017-07-10 13:18 ` Michael Heerdegen
2017-07-10 12:50 ` Michael Heerdegen
2017-07-06 14:56 ` Nicolas Petton
2017-07-07 6:39 ` Tino Calancha
2017-07-07 8:11 ` Nicolas Petton
2017-07-07 8:22 ` Tino Calancha
2017-07-07 8:34 ` Nicolas Petton
2017-07-07 15:49 ` Stefan Monnier
2017-07-07 15:54 ` Nicolas Petton
2017-07-07 19:47 ` Nicolas Petton [this message]
2017-07-08 6:30 ` Eli Zaretskii
2017-07-08 7:02 ` Tino Calancha
2017-07-08 7:14 ` Eli Zaretskii
2017-07-08 11:32 ` Nicolas Petton
2017-07-08 11:46 ` Eli Zaretskii
2017-07-09 14:48 ` Tino Calancha
2017-07-09 19:18 ` Nicolas Petton
2017-07-11 8:08 ` Nicolas Petton
2017-07-11 9:19 ` Tino Calancha
2017-07-12 17:36 ` Michael Heerdegen
2017-07-14 5:19 ` Tino Calancha
2017-07-14 11:16 ` Nicolas Petton
2017-07-17 13:38 ` Tino Calancha
2017-08-01 16:37 ` Nicolas Petton
2017-08-01 16:49 ` Nicolas Petton
2017-08-01 18:53 ` Eli Zaretskii
2017-07-08 11:29 ` Nicolas Petton
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=8737a858so.fsf@petton.fr \
--to=nicolas@petton.fr \
--cc=27584@debbugs.gnu.org \
--cc=monnier@IRO.UMontreal.CA \
--cc=tino.calancha@gmail.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.