Stefan Monnier 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 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