Commit 0bece6c6 authored by NicolasPetton's avatar NicolasPetton

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.
parent 689c5c20
......@@ -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)))
......
......@@ -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'.
......
......@@ -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)
......
......@@ -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);
......
......@@ -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);
......
......@@ -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);
......
......@@ -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))
......
......@@ -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)
......
......@@ -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
......
......@@ -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)))
{
......
......@@ -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))
{
......
......@@ -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
......
......@@ -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);
......
......@@ -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))
{
......
......@@ -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))
{
......
......@@ -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);
......
......@@ -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. */
......@@ -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. */
......
......@@ -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)))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment