GNU bug report logs -
#27584
26.0.50; alist-get: Add optional arg TESTFN
Previous Next
Reported by: Tino Calancha <tino.calancha <at> gmail.com>
Date: Wed, 5 Jul 2017 03:24:02 UTC
Severity: wishlist
Found in version 26.0.50
Done: Tino Calancha <tino.calancha <at> gmail.com>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 27584 in the body.
You can then email your comments to 27584 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
Report forwarded
to
nicolas <at> petton.fr, monnier <at> iro.umontreal.ca, bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Wed, 05 Jul 2017 03:24:02 GMT)
Full text and
rfc822 format available.
Acknowledgement sent
to
Tino Calancha <tino.calancha <at> gmail.com>:
New bug report received and forwarded. Copy sent to
nicolas <at> petton.fr, monnier <at> iro.umontreal.ca, bug-gnu-emacs <at> gnu.org.
(Wed, 05 Jul 2017 03:24:02 GMT)
Full text and
rfc822 format available.
Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
Severity: wishlist
X-Debbugs-CC: Nicolas Petton <nicolas <at> petton.fr>, Stefan Monnier <monnier <at> iro.umontreal.ca>
Consider the following question:
https://emacs.stackexchange.com/questions/33892/replace-element-of-alist-using-equal-even-if-key-does-not-exist/33893#33893
1. The OP wants to update an alist without adding duplicates,
2. but he doesn't want to restrict the lookup in the alist to 'eq'.
The OP realized that
(setf (alist-get key alist) val)
is not an option because, `alist-get' assumes 'eq' in the lookup.
Then he writes his own function:
;; docstrig omitted:
(defun alist-set (key val alist &optional symbol)
(if-let ((pair (if symbol (assq key alist) (assoc key alist))))
(setcdr pair val)
(push (cons key val) alist))
alist)
* In the same thread, Drew suggests to add an optional arg TESTFN in `alist-get'.
* We might also tweak `map.el' so that the following code works:
(progn
(setq map (list (cons "a" 1) (cons "b" 2)))
(require 'map)
(map-put map "a" 'foo 'equal)
map)
=> (("a" . foo) ("b" . 2))
;; Without 'equal in `map-put' that would yield:
;; (("a" . foo) ("a" . 1) ("b" . 2))
--8<-----------------------------cut here---------------start------------->8---
commit 2c020d77c7e74b8ca415cb6370aac5bac86df452
Author: Tino Calancha <tino.calancha <at> gmail.com>
Date: Wed Jul 5 12:18:53 2017 +0900
alist-get: Add optional arg TESTFN
If TESTFN is non-nil, then it is the predicate to lookup
the alist. Otherwise, use 'eq' (Bug#27584).
* lisp/subr.el (assoc-default): Add optional arg FULL.
(alist-get)
* lisp/emacs-lisp/map.el (map-elt, map-put): Add optional arg TESTFN.
* lisp/emacs-lisp/gv.el (alist-get): Update expander.
* doc/lispref/lists.texi (Association Lists): Update manual.
* etc/NEWS: Announce the changes.
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 8eab2818f9..d2ae3028d8 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1589,10 +1589,14 @@ Association Lists
@end smallexample
@end defun
-@defun alist-get key alist &optional default remove
-This function is like @code{assq}, but instead of returning the entire
+@defun alist-get key alist &optional default remove testfn
+This function is like @code{assq} when @var{testfn} is @code{nil},
+but instead of returning the entire
association for @var{key} in @var{alist},
@w{@code{(@var{key} . @var{value})}}, it returns just the @var{value}.
+When @var{testfn} is non-@code{nil}, it returns @var{value} if @var{key}
+is equal to the car of an element of @var{alist}. The equality is
+tested with @var{testfn}.
If @var{key} is not found in @var{alist}, it returns @var{default}.
This is a generalized variable (@pxref{Generalized Variables}) that
@@ -1640,7 +1644,7 @@ Association Lists
@end smallexample
@end defun
-@defun assoc-default key alist &optional test default
+@defun assoc-default key alist &optional test default full
This function searches @var{alist} for a match for @var{key}. For each
element of @var{alist}, it compares the element (if it is an atom) or
the element's @sc{car} (if it is a cons) against @var{key}, by calling
@@ -1652,7 +1656,8 @@ Association Lists
If an alist element matches @var{key} by this criterion,
then @code{assoc-default} returns a value based on this element.
-If the element is a cons, then the value is the element's @sc{cdr}.
+If the element is a cons, then the value is the element if @var{full}
+is non-@code{nil}, or the element's @sc{cdr} if @var{full} is @code{nil}.
Otherwise, the return value is @var{default}.
If no alist element matches @var{key}, @code{assoc-default} returns
diff --git a/etc/NEWS b/etc/NEWS
index 83cb73f4a9..dca9809795 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1046,6 +1046,11 @@ break.
* Lisp Changes in Emacs 26.1
+** New optional argument FULL in 'assoc-default', to return the full
+matching element.
+
+** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'.
+
** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2
contain the same elements, regardless of the order.
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index c5c12a6414..166881a458 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -377,10 +377,12 @@ setf
`(with-current-buffer ,buf (set (make-local-variable ,var) ,v))))
(gv-define-expander alist-get
- (lambda (do key alist &optional default remove)
+ (lambda (do key alist &optional default remove testfn)
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
- (macroexp-let2 nil p `(assq ,k ,getter)
+ (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
+ (assoc-default ,k ,getter ,testfn nil 'full)
+ (assq ,k ,getter))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
(lambda (v)
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index a89457e877..f3850f5844 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -93,11 +93,11 @@ map-let
((arrayp ,map-var) ,(plist-get args :array))
(t (error "Unsupported map: %s" ,map-var)))))
-(defun map-elt (map key &optional default)
+(defun map-elt (map key &optional default testfn)
"Lookup KEY in MAP and return its associated value.
If KEY is not found, return DEFAULT which defaults to nil.
-If MAP is a list, `eql' is used to lookup KEY.
+If MAP is a list, TESTFN is used to lookup KEY if non-nil or `eql' if nil.
MAP can be a list, hash-table or array."
(declare
@@ -106,30 +106,31 @@ map-elt
(gv-letplace (mgetter msetter) `(gv-delay-error ,map)
(macroexp-let2* nil
;; Eval them once and for all in the right order.
- ((key key) (default default))
+ ((key key) (default default) (testfn testfn))
`(if (listp ,mgetter)
;; Special case the alist case, since it can't be handled by the
;; map--put function.
,(gv-get `(alist-get ,key (gv-synthetic-place
,mgetter ,msetter)
- ,default)
+ ,default nil ,testfn)
do)
,(funcall do `(map-elt ,mgetter ,key ,default)
(lambda (v) `(map--put ,mgetter ,key ,v)))))))))
(map--dispatch map
- :list (alist-get key map default)
+ :list (alist-get key map default nil testfn)
:hash-table (gethash key map default)
:array (if (and (>= key 0) (< key (seq-length map)))
(seq-elt map key)
default)))
-(defmacro map-put (map key value)
+(defmacro map-put (map key value &optional testfn)
"Associate KEY with VALUE in MAP and return VALUE.
If KEY is already present in MAP, replace the associated value
with VALUE.
+When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'.
MAP can be a list, hash-table or array."
- `(setf (map-elt ,map ,key) ,value))
+ `(setf (map-elt ,map ,key nil ,testfn) ,value))
(defun map-delete (map key)
"Delete KEY from MAP and return MAP.
diff --git a/lisp/subr.el b/lisp/subr.el
index a9edff6166..01c6c1628f 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -650,23 +650,27 @@ copy-tree
;;;; Various list-search functions.
-(defun assoc-default (key alist &optional test default)
+(defun assoc-default (key alist &optional test default full)
"Find object KEY in a pseudo-alist ALIST.
ALIST is a list of conses or objects. Each element
(or the element's car, if it is a cons) is compared with KEY by
calling TEST, with two arguments: (i) the element or its car,
and (ii) KEY.
If that is non-nil, the element matches; then `assoc-default'
- returns the element's cdr, if it is a cons, or DEFAULT if the
- element is not a cons.
+ returns the element, if it is a cons and FULL is non-nil,
+ or the element's cdr, if it is a cons and FULL is nil,
+ or DEFAULT if the element is not a cons.
If no element matches, the value is nil.
If TEST is omitted or nil, `equal' is used."
(let (found (tail alist) value)
(while (and tail (not found))
(let ((elt (car tail)))
- (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
- (setq found t value (if (consp elt) (cdr elt) default))))
+ (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
+ (setq found t
+ value (cond ((consp elt)
+ (if full elt (cdr elt)))
+ (t default)))))
(setq tail (cdr tail)))
value))
@@ -725,15 +729,18 @@ rassq-delete-all
(setq tail tail-cdr))))
alist)
-(defun alist-get (key alist &optional default remove)
- "Return the value associated with KEY in ALIST, using `assq'.
+(defun alist-get (key alist &optional default remove testfn)
+ "Return the value associated with KEY in ALIST.
If KEY is not found in ALIST, return DEFAULT.
+Use TESTFN to lookup in the alist if non-nil. Otherwise, use `assq'.
This is a generalized variable suitable for use with `setf'.
When using it to set a value, optional argument REMOVE non-nil
means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
(ignore remove) ;;Silence byte-compiler.
- (let ((x (assq key alist)))
+ (let ((x (if (and testfn (not (eq testfn 'eq)))
+ (assoc-default key alist testfn nil 'full)
+ (assq key alist))))
(if x (cdr x) default)))
(defun remove (elt seq)
--8<-----------------------------cut here---------------end--------------->8---
In GNU Emacs 26.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.22.11)
of 2017-07-05
Repository revision: 5d62247323f53f3ae9c7d9f51e951635887b2fb6
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Wed, 05 Jul 2017 08:54:02 GMT)
Full text and
rfc822 format available.
Message #8 received at 27584 <at> debbugs.gnu.org (full text, mbox):
>
> -(defun assoc-default (key alist &optional test default)
> +(defun assoc-default (key alist &optional test default full)
> "Find object KEY in a pseudo-alist ALIST.
> ALIST is a list of conses or objects. Each element
> (or the element's car, if it is a cons) is compared with KEY by
> calling TEST, with two arguments: (i) the element or its car,
> and (ii) KEY.
> If that is non-nil, the element matches; then `assoc-default'
> - returns the element's cdr, if it is a cons, or DEFAULT if the
> - element is not a cons.
> + returns the element, if it is a cons and FULL is non-nil,
> + or the element's cdr, if it is a cons and FULL is nil,
> + or DEFAULT if the element is not a cons.
>
> If no element matches, the value is nil.
> If TEST is omitted or nil, `equal' is used."
> (let (found (tail alist) value)
> (while (and tail (not found))
> (let ((elt (car tail)))
> - (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
> - (setq found t value (if (consp elt) (cdr elt) default))))
> + (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
> + (setq found t
> + value (cond ((consp elt)
> + (if full elt (cdr elt)))
> + (t default)))))
> (setq tail (cdr tail)))
> value))
If we go in this direction, then i think it has sense to add
something with less parameters, like this:
(defsubst assoc-predicate (key alist test)
"Like `assoc' but compare keys with TEST."
(assoc-default key alist test nil 'full))
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Wed, 05 Jul 2017 09:20:02 GMT)
Full text and
rfc822 format available.
Message #11 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Tino Calancha <tino.calancha <at> gmail.com> writes:
> Consider the following question:
> https://emacs.stackexchange.com/questions/33892/replace-element-of-alist-using-equal-even-if-key-does-not-exist/33893#33893
>
> 1. The OP wants to update an alist without adding duplicates,
> 2. but he doesn't want to restrict the lookup in the alist to 'eq'.
>
> The OP realized that
>
> (setf (alist-get key alist) val)
>
> is not an option because, `alist-get' assumes 'eq' in the lookup.
> Then he writes his own function:
> ;; docstrig omitted:
> (defun alist-set (key val alist &optional symbol)
> (if-let ((pair (if symbol (assq key alist) (assoc key alist))))
> (setcdr pair val)
> (push (cons key val) alist))
> alist)
>
> * In the same thread, Drew suggests to add an optional arg TESTFN in `alist-get'.
> * We might also tweak `map.el' so that the following code works:
Thanks, I like your changes. If this is going to be installed, could
you add tests to map-tests.el as well?
Cheers,
Nico
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Wed, 05 Jul 2017 13:20:01 GMT)
Full text and
rfc822 format available.
Message #14 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Wed, 5 Jul 2017, Nicolas Petton wrote:
> Thanks, I like your changes. If this is going to be installed, could
> you add tests to map-tests.el as well?
Sure, i have that in mind. I will prepare them by tomorrow while
Stefan take a look on it.
Cheers,
Tino
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Thu, 06 Jul 2017 06:06:01 GMT)
Full text and
rfc822 format available.
Message #17 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Tino Calancha <tino.calancha <at> gmail.com> writes:
> On Wed, 5 Jul 2017, Nicolas Petton wrote:
>
>> Thanks, I like your changes. If this is going to be installed, could
>> you add tests to map-tests.el as well?
OK, done!
(See patch below)
I have a few questions:
1. In my patch `assoc-predicate' is a defsubst.
Should does exit at all?
If yes:
*) should be a defun instead?
**) should be named `assoc-predicate' or differently?
2. Should i collapse those 3 new 'etc/NEWS' entries in just 1 or 2?
--8<-----------------------------cut here---------------start------------->8---
commit a7f6ac2a09de893a42b086ec2dabbeeac7ba4cb4
Author: Tino Calancha <tino.calancha <at> gmail.com>
Date: Thu Jul 6 14:47:43 2017 +0900
alist-get: Add optional arg TESTFN
If TESTFN is non-nil, then it is the predicate to lookup
the alist. Otherwise, use 'eq' (Bug#27584).
* lisp/subr.el (assoc-default): Add optional arg FULL.
(alist-get)
* lisp/emacs-lisp/map.el (map-elt, map-put): Add optional arg TESTFN.
* lisp/emacs-lisp/gv.el (alist-get): Update expander.
* doc/lispref/lists.texi (Association Lists): Update manual.
* etc/NEWS: Announce the changes.
* test/lisp/emacs-lisp/map-tests.el (test-map-put-testfn-alist)
(test-map-elt-testfn): New tests.
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 8eab2818f9..d2ae3028d8 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1589,10 +1589,14 @@ Association Lists
@end smallexample
@end defun
-@defun alist-get key alist &optional default remove
-This function is like @code{assq}, but instead of returning the entire
+@defun alist-get key alist &optional default remove testfn
+This function is like @code{assq} when @var{testfn} is @code{nil},
+but instead of returning the entire
association for @var{key} in @var{alist},
@w{@code{(@var{key} . @var{value})}}, it returns just the @var{value}.
+When @var{testfn} is non-@code{nil}, it returns @var{value} if @var{key}
+is equal to the car of an element of @var{alist}. The equality is
+tested with @var{testfn}.
If @var{key} is not found in @var{alist}, it returns @var{default}.
This is a generalized variable (@pxref{Generalized Variables}) that
@@ -1640,7 +1644,7 @@ Association Lists
@end smallexample
@end defun
-@defun assoc-default key alist &optional test default
+@defun assoc-default key alist &optional test default full
This function searches @var{alist} for a match for @var{key}. For each
element of @var{alist}, it compares the element (if it is an atom) or
the element's @sc{car} (if it is a cons) against @var{key}, by calling
@@ -1652,7 +1656,8 @@ Association Lists
If an alist element matches @var{key} by this criterion,
then @code{assoc-default} returns a value based on this element.
-If the element is a cons, then the value is the element's @sc{cdr}.
+If the element is a cons, then the value is the element if @var{full}
+is non-@code{nil}, or the element's @sc{cdr} if @var{full} is @code{nil}.
Otherwise, the return value is @var{default}.
If no alist element matches @var{key}, @code{assoc-default} returns
diff --git a/etc/NEWS b/etc/NEWS
index 13805ce0da..a395ac7aec 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1050,6 +1050,13 @@ break.
* Lisp Changes in Emacs 26.1
++++
+** New optional argument FULL in 'assoc-default', to return the full
+matching element.
+
++++
+** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'.
+
** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2
contain the same elements, regardless of the order.
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index c5c12a6414..166881a458 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -377,10 +377,12 @@ setf
`(with-current-buffer ,buf (set (make-local-variable ,var) ,v))))
(gv-define-expander alist-get
- (lambda (do key alist &optional default remove)
+ (lambda (do key alist &optional default remove testfn)
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
- (macroexp-let2 nil p `(assq ,k ,getter)
+ (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
+ (assoc-default ,k ,getter ,testfn nil 'full)
+ (assq ,k ,getter))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
(lambda (v)
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index a89457e877..f3850f5844 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -93,11 +93,11 @@ map-let
((arrayp ,map-var) ,(plist-get args :array))
(t (error "Unsupported map: %s" ,map-var)))))
-(defun map-elt (map key &optional default)
+(defun map-elt (map key &optional default testfn)
"Lookup KEY in MAP and return its associated value.
If KEY is not found, return DEFAULT which defaults to nil.
-If MAP is a list, `eql' is used to lookup KEY.
+If MAP is a list, TESTFN is used to lookup KEY if non-nil or `eql' if nil.
MAP can be a list, hash-table or array."
(declare
@@ -106,30 +106,31 @@ map-elt
(gv-letplace (mgetter msetter) `(gv-delay-error ,map)
(macroexp-let2* nil
;; Eval them once and for all in the right order.
- ((key key) (default default))
+ ((key key) (default default) (testfn testfn))
`(if (listp ,mgetter)
;; Special case the alist case, since it can't be handled by the
;; map--put function.
,(gv-get `(alist-get ,key (gv-synthetic-place
,mgetter ,msetter)
- ,default)
+ ,default nil ,testfn)
do)
,(funcall do `(map-elt ,mgetter ,key ,default)
(lambda (v) `(map--put ,mgetter ,key ,v)))))))))
(map--dispatch map
- :list (alist-get key map default)
+ :list (alist-get key map default nil testfn)
:hash-table (gethash key map default)
:array (if (and (>= key 0) (< key (seq-length map)))
(seq-elt map key)
default)))
-(defmacro map-put (map key value)
+(defmacro map-put (map key value &optional testfn)
"Associate KEY with VALUE in MAP and return VALUE.
If KEY is already present in MAP, replace the associated value
with VALUE.
+When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'.
MAP can be a list, hash-table or array."
- `(setf (map-elt ,map ,key) ,value))
+ `(setf (map-elt ,map ,key nil ,testfn) ,value))
(defun map-delete (map key)
"Delete KEY from MAP and return MAP.
diff --git a/lisp/subr.el b/lisp/subr.el
index a9edff6166..01c6c1628f 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -650,23 +650,27 @@ copy-tree
;;;; Various list-search functions.
-(defun assoc-default (key alist &optional test default)
+(defun assoc-default (key alist &optional test default full)
"Find object KEY in a pseudo-alist ALIST.
ALIST is a list of conses or objects. Each element
(or the element's car, if it is a cons) is compared with KEY by
calling TEST, with two arguments: (i) the element or its car,
and (ii) KEY.
If that is non-nil, the element matches; then `assoc-default'
- returns the element's cdr, if it is a cons, or DEFAULT if the
- element is not a cons.
+ returns the element, if it is a cons and FULL is non-nil,
+ or the element's cdr, if it is a cons and FULL is nil,
+ or DEFAULT if the element is not a cons.
If no element matches, the value is nil.
If TEST is omitted or nil, `equal' is used."
(let (found (tail alist) value)
(while (and tail (not found))
(let ((elt (car tail)))
- (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
- (setq found t value (if (consp elt) (cdr elt) default))))
+ (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
+ (setq found t
+ value (cond ((consp elt)
+ (if full elt (cdr elt)))
+ (t default)))))
(setq tail (cdr tail)))
value))
@@ -725,15 +729,18 @@ rassq-delete-all
(setq tail tail-cdr))))
alist)
-(defun alist-get (key alist &optional default remove)
- "Return the value associated with KEY in ALIST, using `assq'.
+(defun alist-get (key alist &optional default remove testfn)
+ "Return the value associated with KEY in ALIST.
If KEY is not found in ALIST, return DEFAULT.
+Use TESTFN to lookup in the alist if non-nil. Otherwise, use `assq'.
This is a generalized variable suitable for use with `setf'.
When using it to set a value, optional argument REMOVE non-nil
means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
(ignore remove) ;;Silence byte-compiler.
- (let ((x (assq key alist)))
+ (let ((x (if (and testfn (not (eq testfn 'eq)))
+ (assoc-default key alist testfn nil 'full)
+ (assq key alist))))
(if x (cdr x) default)))
(defun remove (elt seq)
diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el
index 07e85cc539..15b0655040 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -63,6 +63,11 @@ with-maps-do
(with-maps-do map
(should (= 5 (map-elt map 7 5)))))
+(ert-deftest test-map-elt-testfn ()
+ (let ((map (list (cons "a" 1) (cons "b" 2))))
+ (should-not (map-elt map "a"))
+ (should (map-elt map "a" nil 'equal))))
+
(ert-deftest test-map-elt-with-nil-value ()
(should (null (map-elt '((a . 1)
(b))
@@ -94,6 +99,13 @@ with-maps-do
(should (eq (map-elt alist 2)
'b))))
+(ert-deftest test-map-put-testfn-alist ()
+ (let ((alist (list (cons "a" 1) (cons "b" 2))))
+ (map-put alist "a" 3 'equal)
+ (should-not (cddr alist))
+ (map-put alist "a" 9)
+ (should (cddr alist))))
+
(ert-deftest test-map-put-return-value ()
(let ((ht (make-hash-table)))
(should (eq (map-put ht 'a 'hello) 'hello))))
commit 4bb22ad2203ac54e5f873fcf624e26642e1557c1
Author: Tino Calancha <tino.calancha <at> gmail.com>
Date: Thu Jul 6 14:48:44 2017 +0900
assoc-predicate: New defsubst
* lisp/subr.el (assoc-predicate): New defsubst.
(alist-get):
* lisp/emacs-lisp/gv.el (alist-get): Use it.
* doc/lispref/lists.texi (Association Lists): Update manual.
* etc/NEWS: Announce the feature.
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index d2ae3028d8..98a79990a4 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1589,6 +1589,24 @@ Association Lists
@end smallexample
@end defun
+@defun assoc-predicate key alist test
+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{test} instead of @code{equal}. @code{assoc-predicate}
+returns @code{nil} if no association in @var{alist} has a @sc{car},
+@var{x}, satisfying @code{(funcall test x key)}.
+
+@smallexample
+(setq leaves
+ '(("simple leaves" . oak)
+ ("compound leaves" . horsechestnut)))
+
+(assoc-predicate "simple leaves" leaves 'string=)
+ @result{} ("simple leaves" . oak)
+@end smallexample
+
+@end defun
+
@defun alist-get key alist &optional default remove testfn
This function is like @code{assq} when @var{testfn} is @code{nil},
but instead of returning the entire
diff --git a/etc/NEWS b/etc/NEWS
index a395ac7aec..4d23563215 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1051,6 +1051,9 @@ break.
* Lisp Changes in Emacs 26.1
+++
+** New defsubst 'assoc-predicate'.
+
++++
** New optional argument FULL in 'assoc-default', to return the full
matching element.
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 166881a458..29b85e280e 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -381,7 +381,7 @@ setf
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
(macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
- (assoc-default ,k ,getter ,testfn nil 'full)
+ (assoc-predicate ,k ,getter ,testfn)
(assq ,k ,getter))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
diff --git a/lisp/subr.el b/lisp/subr.el
index 01c6c1628f..1d1f39731f 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -674,6 +674,10 @@ assoc-default
(setq tail (cdr tail)))
value))
+(defsubst assoc-predicate (key alist test)
+ "Like `assoc' but compare keys with TEST."
+ (assoc-default key alist test nil 'full))
+
(defun assoc-ignore-case (key alist)
"Like `assoc', but ignores differences in case and text representation.
KEY must be a string. Upper-case and lower-case letters are treated as equal.
@@ -739,7 +743,7 @@ alist-get
means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
(ignore remove) ;;Silence byte-compiler.
(let ((x (if (and testfn (not (eq testfn 'eq)))
- (assoc-default key alist testfn nil 'full)
+ (assoc-predicate key alist testfn)
(assq key alist))))
(if x (cdr x) default)))
--8<-----------------------------cut here---------------end--------------->8---
In GNU Emacs 26.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.22.11)
of 2017-07-06
Repository revision: 7a0170de20fe1225d3eeac099d1e61a0c0410bf3
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Thu, 06 Jul 2017 06:14:02 GMT)
Full text and
rfc822 format available.
Message #20 received at 27584 <at> debbugs.gnu.org (full text, mbox):
> 1. In my patch `assoc-predicate' is a defsubst.
> Should does exit at all?
> If yes:
> *) should be a defun instead?
> **) should be named `assoc-predicate' or differently?
It's been called cl-assoc so far ;-)
Stefan
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Thu, 06 Jul 2017 06:21:01 GMT)
Full text and
rfc822 format available.
Message #23 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Thu, 6 Jul 2017, Stefan Monnier wrote:
>> 1. In my patch `assoc-predicate' is a defsubst.
>> Should does exit at all?
>> If yes:
>> *) should be a defun instead?
>> **) should be named `assoc-predicate' or differently?
>
> It's been called cl-assoc so far ;-)
Some day your dream will be fulfilled, and `cl-lib' will be preloaded at
startup. Then, we will not need things like `assoc-predicate'.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Thu, 06 Jul 2017 09:37:01 GMT)
Full text and
rfc822 format available.
Message #26 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Tino Calancha <tino.calancha <at> gmail.com> writes:
>> It's been called cl-assoc so far ;-)
> Some day your dream will be fulfilled, and `cl-lib' will be preloaded at
> startup. Then, we will not need things like `assoc-predicate'.
map.el could require cl-lib and use cl-assoc?
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Thu, 06 Jul 2017 10:56:02 GMT)
Full text and
rfc822 format available.
Message #29 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Thu, 6 Jul 2017, Nicolas Petton wrote:
> Tino Calancha <tino.calancha <at> gmail.com> writes:
>
>>> It's been called cl-assoc so far ;-)
>
>> Some day your dream will be fulfilled, and `cl-lib' will be preloaded at
>> startup. Then, we will not need things like `assoc-predicate'.
>
> map.el could require cl-lib and use cl-assoc?
Actually, it already does require cl-lib, because the following chain:
* map.el requires `seq'
* seq.el requires `cl-lib'
Indeed, in my patch `assoc-predicate' doesn't appear in map.el,
so it's not just a matter of replace:
assoc-predicate ---> cl-assoc
`assoc-predicate' appears in the implementation (subr.el)
and setter expansion (gv.el) of `alist-get'.
Neither subr.el nor gv.el are requiring `cl-lib'.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Thu, 06 Jul 2017 11:07:02 GMT)
Full text and
rfc822 format available.
Message #32 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Tino Calancha <tino.calancha <at> gmail.com> writes:
> `assoc-predicate' appears in the implementation (subr.el)
> and setter expansion (gv.el) of `alist-get'.
>
> Neither subr.el nor gv.el are requiring `cl-lib'.
Oh, right, indeed.
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Thu, 06 Jul 2017 14:58:01 GMT)
Full text and
rfc822 format available.
Message #35 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Tino Calancha <tino.calancha <at> gmail.com> writes:
> 1. In my patch `assoc-predicate' is a defsubst.
> Should does exit at all?
I would inline its call and use `assoc-default' directly, but I guess
it's a matter of taste.
But wouldn't it be better if `assoc' took an optional testfn? I'm not
sure I like the `full' parameter in `assoc-default', and I think the
inconsistency of the return values between `assoc' and `assoc-default'
is already confusing.
Nico
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Thu, 06 Jul 2017 15:08:02 GMT)
Full text and
rfc822 format available.
Message #38 received at 27584 <at> debbugs.gnu.org (full text, mbox):
>>> 1. In my patch `assoc-predicate' is a defsubst.
>>> Should does exit at all?
>>> If yes:
>>> *) should be a defun instead?
>>> **) should be named `assoc-predicate' or differently?
>> It's been called cl-assoc so far ;-)
> Some day your dream will be fulfilled, and `cl-lib' will be preloaded at
> startup.
I'm not sure it's my dream, to tell you the truth: I like Scheme's
choice of not treating "keyword symbols" specially, so macros can use
them (because the keyword args aren't evaluated), but not functions.
This ensures that the cost of keyword-argument parsing is only paid
during macro expansion (where it's tolerable) but not at run-time
(where it's much too costly and hence absolutely requires
compiler-macro crutches).
> Then, we will not need things like `assoc-predicate'.
In reality, my intention, beside putting a smiley, was to point you to another
implementation which uses defun with a compiler-macro instead of
defsubst. Actually your assoc-predicate might be a good candidate for
define-inline (which is in dire need of documentation. I can't believe
its author still hasn't bothered to put even a docstring).
Something like
(define-inline assoc-predicate (elem list &optional pred)
(inline-letevals (elem list pred)
(pcase (inline-const-val pred)
('eq (inline-quote (assq ,elem ,list)))
((or 'equal 'nil) (inline-quote (assoc ,elem ,list)))
(_ (inline-quote (assoc-default ,elem ,list ,pred nil 'full))))))
-- Stefan
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 06:40:02 GMT)
Full text and
rfc822 format available.
Message #41 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Nicolas Petton <nicolas <at> petton.fr> writes:
> Tino Calancha <tino.calancha <at> gmail.com> writes:
>
>
>> 1. In my patch `assoc-predicate' is a defsubst.
>> Should does exit at all?
>
> I would inline its call and use `assoc-default' directly, but I guess
> it's a matter of taste.
Following Stefan suggestion, we can optimize using a compiler macro.
Then, `assoc-default' is just the default case.
>
> But wouldn't it be better if `assoc' took an optional testfn? I'm not
> sure I like the `full' parameter in `assoc-default', and I think the
> inconsistency of the return values between `assoc' and `assoc-default'
> is already confusing.
In fact, that would kill 2 birds in a shot.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 06:49:01 GMT)
Full text and
rfc822 format available.
Message #44 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Stefan Monnier <monnier <at> IRO.UMontreal.CA> writes:
>>>> **) should be named `assoc-predicate' or differently?
>>> It's been called cl-assoc so far ;-)
>> Some day your dream will be fulfilled, and `cl-lib' will be preloaded at
>> startup.
>
> I'm not sure it's my dream, to tell you the truth: I like Scheme's
> choice of not treating "keyword symbols" specially, so macros can use
> them (because the keyword args aren't evaluated), but not functions.
> This ensures that the cost of keyword-argument parsing is only paid
> during macro expansion (where it's tolerable) but not at run-time
> (where it's much too costly and hence absolutely requires
> compiler-macro crutches).
thanks for th explanations. I see your point now.
>> Then, we will not need things like `assoc-predicate'.
>
> In reality, my intention, beside putting a smiley, was to point you to another
> implementation which uses defun with a compiler-macro instead of
> defsubst. Actually your assoc-predicate might be a good candidate for
> define-inline (which is in dire need of documentation. I can't believe
> its author still hasn't bothered to put even a docstring).
>
> Something like
>
> (define-inline assoc-predicate (elem list &optional pred)
> (inline-letevals (elem list pred)
> (pcase (inline-const-val pred)
> ('eq (inline-quote (assq ,elem ,list)))
> ((or 'equal 'nil) (inline-quote (assoc ,elem ,list)))
> (_ (inline-quote (assoc-default ,elem ,list ,pred nil 'full))))))
Yes, that sounds much better!
I adapted your example into subr.el after stole from
`cl--compiler-macro-assoc' another optimization.
(See updated patch below)
Nico, one thing worries me is the following:
* After this patch, `map.el' v1.2 depends on Emacs version > 25:
* because it makes a call to `alist-get' with 5 parameters i.e., it
uses TESTFN.
Is that a problem?
--8<-----------------------------cut here---------------start------------->8---
commit b4855d2d641b9fe4e6a49e898f797c40fe872281
Author: Tino Calancha <tino.calancha <at> gmail.com>
Date: Fri Jul 7 15:29:15 2017 +0900
alist-get: Add optional arg TESTFN
If TESTFN is non-nil, then it is the predicate to lookup
the alist. Otherwise, use 'eq' (Bug#27584).
* lisp/subr.el (assoc-default): Add optional arg FULL.
(alist-get)
* lisp/emacs-lisp/map.el (map-elt, map-put): Add optional arg TESTFN.
* lisp/emacs-lisp/gv.el (alist-get): Update expander.
* doc/lispref/lists.texi (Association Lists): Update manual.
* etc/NEWS: Announce the changes.
* test/lisp/emacs-lisp/map-tests.el (test-map-put-testfn-alist)
(test-map-elt-testfn): New tests.
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 8eab2818f9..d2ae3028d8 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1589,10 +1589,14 @@ Association Lists
@end smallexample
@end defun
-@defun alist-get key alist &optional default remove
-This function is like @code{assq}, but instead of returning the entire
+@defun alist-get key alist &optional default remove testfn
+This function is like @code{assq} when @var{testfn} is @code{nil},
+but instead of returning the entire
association for @var{key} in @var{alist},
@w{@code{(@var{key} . @var{value})}}, it returns just the @var{value}.
+When @var{testfn} is non-@code{nil}, it returns @var{value} if @var{key}
+is equal to the car of an element of @var{alist}. The equality is
+tested with @var{testfn}.
If @var{key} is not found in @var{alist}, it returns @var{default}.
This is a generalized variable (@pxref{Generalized Variables}) that
@@ -1640,7 +1644,7 @@ Association Lists
@end smallexample
@end defun
-@defun assoc-default key alist &optional test default
+@defun assoc-default key alist &optional test default full
This function searches @var{alist} for a match for @var{key}. For each
element of @var{alist}, it compares the element (if it is an atom) or
the element's @sc{car} (if it is a cons) against @var{key}, by calling
@@ -1652,7 +1656,8 @@ Association Lists
If an alist element matches @var{key} by this criterion,
then @code{assoc-default} returns a value based on this element.
-If the element is a cons, then the value is the element's @sc{cdr}.
+If the element is a cons, then the value is the element if @var{full}
+is non-@code{nil}, or the element's @sc{cdr} if @var{full} is @code{nil}.
Otherwise, the return value is @var{default}.
If no alist element matches @var{key}, @code{assoc-default} returns
diff --git a/etc/NEWS b/etc/NEWS
index 13805ce0da..a395ac7aec 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1050,6 +1050,13 @@ break.
* Lisp Changes in Emacs 26.1
++++
+** New optional argument FULL in 'assoc-default', to return the full
+matching element.
+
++++
+** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'.
+
** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2
contain the same elements, regardless of the order.
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index c5c12a6414..166881a458 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -377,10 +377,12 @@ setf
`(with-current-buffer ,buf (set (make-local-variable ,var) ,v))))
(gv-define-expander alist-get
- (lambda (do key alist &optional default remove)
+ (lambda (do key alist &optional default remove testfn)
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
- (macroexp-let2 nil p `(assq ,k ,getter)
+ (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
+ (assoc-default ,k ,getter ,testfn nil 'full)
+ (assq ,k ,getter))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
(lambda (v)
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index a89457e877..e25502d76f 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Petton <nicolas <at> petton.fr>
;; Keywords: convenience, map, hash-table, alist, array
-;; Version: 1.1
+;; Version: 1.2
;; Package: map
;; Maintainer: emacs-devel <at> gnu.org
@@ -93,11 +93,11 @@ map-let
((arrayp ,map-var) ,(plist-get args :array))
(t (error "Unsupported map: %s" ,map-var)))))
-(defun map-elt (map key &optional default)
+(defun map-elt (map key &optional default testfn)
"Lookup KEY in MAP and return its associated value.
If KEY is not found, return DEFAULT which defaults to nil.
-If MAP is a list, `eql' is used to lookup KEY.
+If MAP is a list, TESTFN is used to lookup KEY if non-nil or `eql' if nil.
MAP can be a list, hash-table or array."
(declare
@@ -106,30 +106,31 @@ map-elt
(gv-letplace (mgetter msetter) `(gv-delay-error ,map)
(macroexp-let2* nil
;; Eval them once and for all in the right order.
- ((key key) (default default))
+ ((key key) (default default) (testfn testfn))
`(if (listp ,mgetter)
;; Special case the alist case, since it can't be handled by the
;; map--put function.
,(gv-get `(alist-get ,key (gv-synthetic-place
,mgetter ,msetter)
- ,default)
+ ,default nil ,testfn)
do)
,(funcall do `(map-elt ,mgetter ,key ,default)
(lambda (v) `(map--put ,mgetter ,key ,v)))))))))
(map--dispatch map
- :list (alist-get key map default)
+ :list (alist-get key map default nil testfn)
:hash-table (gethash key map default)
:array (if (and (>= key 0) (< key (seq-length map)))
(seq-elt map key)
default)))
-(defmacro map-put (map key value)
+(defmacro map-put (map key value &optional testfn)
"Associate KEY with VALUE in MAP and return VALUE.
If KEY is already present in MAP, replace the associated value
with VALUE.
+When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'.
MAP can be a list, hash-table or array."
- `(setf (map-elt ,map ,key) ,value))
+ `(setf (map-elt ,map ,key nil ,testfn) ,value))
(defun map-delete (map key)
"Delete KEY from MAP and return MAP.
diff --git a/lisp/subr.el b/lisp/subr.el
index a9edff6166..01c6c1628f 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -650,23 +650,27 @@ copy-tree
;;;; Various list-search functions.
-(defun assoc-default (key alist &optional test default)
+(defun assoc-default (key alist &optional test default full)
"Find object KEY in a pseudo-alist ALIST.
ALIST is a list of conses or objects. Each element
(or the element's car, if it is a cons) is compared with KEY by
calling TEST, with two arguments: (i) the element or its car,
and (ii) KEY.
If that is non-nil, the element matches; then `assoc-default'
- returns the element's cdr, if it is a cons, or DEFAULT if the
- element is not a cons.
+ returns the element, if it is a cons and FULL is non-nil,
+ or the element's cdr, if it is a cons and FULL is nil,
+ or DEFAULT if the element is not a cons.
If no element matches, the value is nil.
If TEST is omitted or nil, `equal' is used."
(let (found (tail alist) value)
(while (and tail (not found))
(let ((elt (car tail)))
- (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
- (setq found t value (if (consp elt) (cdr elt) default))))
+ (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key)
+ (setq found t
+ value (cond ((consp elt)
+ (if full elt (cdr elt)))
+ (t default)))))
(setq tail (cdr tail)))
value))
@@ -725,15 +729,18 @@ rassq-delete-all
(setq tail tail-cdr))))
alist)
-(defun alist-get (key alist &optional default remove)
- "Return the value associated with KEY in ALIST, using `assq'.
+(defun alist-get (key alist &optional default remove testfn)
+ "Return the value associated with KEY in ALIST.
If KEY is not found in ALIST, return DEFAULT.
+Use TESTFN to lookup in the alist if non-nil. Otherwise, use `assq'.
This is a generalized variable suitable for use with `setf'.
When using it to set a value, optional argument REMOVE non-nil
means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
(ignore remove) ;;Silence byte-compiler.
- (let ((x (assq key alist)))
+ (let ((x (if (and testfn (not (eq testfn 'eq)))
+ (assoc-default key alist testfn nil 'full)
+ (assq key alist))))
(if x (cdr x) default)))
(defun remove (elt seq)
diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el
index 07e85cc539..15b0655040 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -63,6 +63,11 @@ with-maps-do
(with-maps-do map
(should (= 5 (map-elt map 7 5)))))
+(ert-deftest test-map-elt-testfn ()
+ (let ((map (list (cons "a" 1) (cons "b" 2))))
+ (should-not (map-elt map "a"))
+ (should (map-elt map "a" nil 'equal))))
+
(ert-deftest test-map-elt-with-nil-value ()
(should (null (map-elt '((a . 1)
(b))
@@ -94,6 +99,13 @@ with-maps-do
(should (eq (map-elt alist 2)
'b))))
+(ert-deftest test-map-put-testfn-alist ()
+ (let ((alist (list (cons "a" 1) (cons "b" 2))))
+ (map-put alist "a" 3 'equal)
+ (should-not (cddr alist))
+ (map-put alist "a" 9)
+ (should (cddr alist))))
+
(ert-deftest test-map-put-return-value ()
(let ((ht (make-hash-table)))
(should (eq (map-put ht 'a 'hello) 'hello))))
commit 536e4cf1dd8df61edb4bbc580ba1da787ba57f43
Author: Tino Calancha <tino.calancha <at> gmail.com>
Date: Fri Jul 7 15:31:15 2017 +0900
assoc-predicate: New defun
Add new function like 'assoc' with an optional arg PRED,
a predicate to compare the elements in the alist.
* lisp/subr.el (assoc-predicate): New defun.
(alist-get):
* lisp/emacs-lisp/gv.el (alist-get): Use it.
* test/lisp/subr-tests.el (subr-assoc-default, subr-assoc-predicate):
New tests.
* doc/lispref/lists.texi (Association Lists): Update manual.
* etc/NEWS: Announce the feature.
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index d2ae3028d8..b2a0b2df09 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1589,6 +1589,25 @@ Association Lists
@end smallexample
@end defun
+@defun assoc-predicate key alist &optional pred
+This function is like @code{assoc} in that it returns the first
+association for @var{key} in @var{alist}, but if @code{pred} is
+non-@code{nil}, then it makes the comparison using @code{pred}
+instead of @code{equal}. @code{assoc-predicate} returns @code{nil}
+if no association in @var{alist} has a @sc{car}, @var{x}, satisfying
+@code{(funcall pred x key)}.
+
+@smallexample
+(setq leaves
+ '(("simple leaves" . oak)
+ ("compound leaves" . horsechestnut)))
+
+(assoc-predicate "simple leaves" leaves 'string=)
+ @result{} ("simple leaves" . oak)
+@end smallexample
+
+@end defun
+
@defun alist-get key alist &optional default remove testfn
This function is like @code{assq} when @var{testfn} is @code{nil},
but instead of returning the entire
diff --git a/etc/NEWS b/etc/NEWS
index a395ac7aec..e988186b6c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1050,6 +1050,11 @@ break.
* Lisp Changes in Emacs 26.1
+
++++
+** New defun 'assoc-predicate', like 'assoc' with an optional argument
+PRED, a predicate to compare the elements in the alist.
+
+++
** New optional argument FULL in 'assoc-default', to return the full
matching element.
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 166881a458..29b85e280e 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -381,7 +381,7 @@ setf
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
(macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
- (assoc-default ,k ,getter ,testfn nil 'full)
+ (assoc-predicate ,k ,getter ,testfn)
(assq ,k ,getter))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
diff --git a/lisp/subr.el b/lisp/subr.el
index 01c6c1628f..80b10a62c0 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -674,6 +674,19 @@ assoc-default
(setq tail (cdr tail)))
value))
+(defun assoc-predicate (key alist &optional pred)
+ "Like `assoc' but compare keys with TEST."
+ (declare (compiler-macro
+ (lambda (_)
+ `(pcase ,pred
+ ('eq (assq ,key ,alist))
+ ((or 'equal 'nil) (assoc ,key ,alist))
+ ((guard (and (macroexp-const-p ,key) (eq ,pred 'eql)))
+ (if (floatp ,key)
+ (assoc ,key ,alist) (assq ,key ,alist)))
+ (_ (assoc-default ,key ,alist ,pred nil 'full))))))
+ (assoc-default key alist pred nil 'full))
+
(defun assoc-ignore-case (key alist)
"Like `assoc', but ignores differences in case and text representation.
KEY must be a string. Upper-case and lower-case letters are treated as equal.
@@ -739,7 +752,7 @@ alist-get
means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
(ignore remove) ;;Silence byte-compiler.
(let ((x (if (and testfn (not (eq testfn 'eq)))
- (assoc-default key alist testfn nil 'full)
+ (assoc-predicate key alist testfn)
(assq key alist))))
(if x (cdr x) default)))
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 54f4ab5d1b..ab806f74c3 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -325,6 +325,23 @@ subr-tests--this-file
(setq res (read-passwd "pass: " 'confirm (mapconcat #'string default "")))
(should (string= default res)))))
+(ert-deftest subr-assoc-default ()
+ (let ((alist (list (cons "a" 1) (cons "b" 2) "c")))
+ (should (assoc-default "b" alist))
+ (should-not (assoc-default "b" alist 'eq))
+ (should-not (assoc-default "c" alist 'eq 'foo))
+ ;; Return 4th argument if the found element is an atom.
+ (should (equal 'foo (assoc-default "c" alist 'equal 'foo)))
+ (should (equal 2 (assoc-default "b" alist 'equal nil)))
+ (should (equal '("b" . 2) (assoc-default "b" alist 'equal nil 'full)))))
+
+(ert-deftest subr-assoc-predicate ()
+ (let ((alist (list (cons "a" 1) (cons "b" 2) "c")))
+ (should (assoc-predicate "b" alist))
+ (should-not (assoc-predicate "b" alist 'eq))
+ (should-not (assoc-predicate "c" alist 'eq))
+ (should-not (assoc-predicate "c" alist 'equal))
+ (should (equal '("b" . 2) (assoc-predicate "b" alist 'equal)))))
(provide 'subr-tests)
;;; subr-tests.el ends here
--8<-----------------------------cut here---------------end--------------->8---
In GNU Emacs 26.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.22.11)
of 2017-07-07
Repository revision: 51275358e91d654e0cb49b749bf83d2fa19476c7
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 07:48:02 GMT)
Full text and
rfc822 format available.
Message #47 received at 27584 <at> debbugs.gnu.org (full text, mbox):
> From: Tino Calancha <tino.calancha <at> gmail.com>
> Date: Fri, 07 Jul 2017 15:48:01 +0900
> Cc: Nicolas Petton <nicolas <at> petton.fr>,
> Stefan Monnier <monnier <at> IRO.UMontreal.CA>
Thanks. A few comments about the documentation parts:
> -@defun alist-get key alist &optional default remove
> -This function is like @code{assq}, but instead of returning the entire
> +@defun alist-get key alist &optional default remove testfn
> +This function is like @code{assq} when @var{testfn} is @code{nil},
> +but instead of returning the entire
> association for @var{key} in @var{alist},
> @w{@code{(@var{key} . @var{value})}}, it returns just the @var{value}.
> +When @var{testfn} is non-@code{nil}, it returns @var{value} if @var{key}
> +is equal to the car of an element of @var{alist}. The equality is
> +tested with @var{testfn}.
> If @var{key} is not found in @var{alist}, it returns @var{default}.
Sometimes, trying to make small changes to existing documentation
makes the documentation less readable and even confusing. This is one
of those cases: where previously alist-get was only a minor deviation
from assq, and thus just mentioning those deviations would do, now the
deviations are much more significant, and the reference to assq gets
in the way instead of helping. So I would rewrite the documentation
like this:
@defun alist-get key alist &optional default remove testfn
This function is similar to @code{assq}. It finds the first
association @w{@code{(@var{key} . @var{value})}} by comparing
@var{key} with @var{alist} elements, and, if found, returns the
@var{value} of that association. If no association is found, the
function returns @var{default}. Comparison of @var{key} against
@var{alist} elements uses the function specified by @var{testfn},
defaulting to @code{eq}.
The return value is a generalized variable (@pxref{Generalized
Variables}) that can be used to change a value with @code{setf}. When
using it to set a value, optional argument @var{remove} non-@code{nil}
means to remove @var{key}'s association from @var{alist} if the new
value is @code{eql} to @var{default}.
@end defun
> -@defun assoc-default key alist &optional test default
> +@defun assoc-default key alist &optional test default full
> This function searches @var{alist} for a match for @var{key}. For each
> element of @var{alist}, it compares the element (if it is an atom) or
> the element's @sc{car} (if it is a cons) against @var{key}, by calling
> @@ -1652,7 +1656,8 @@ Association Lists
>
> If an alist element matches @var{key} by this criterion,
> then @code{assoc-default} returns a value based on this element.
> -If the element is a cons, then the value is the element's @sc{cdr}.
> +If the element is a cons, then the value is the element if @var{full}
> +is non-@code{nil}, or the element's @sc{cdr} if @var{full} is @code{nil}.
Suggest to simplify:
If the element is a cons, then the value is the element's @sc{cdr}
if @var{full} is @code{nil} or omitted, or the entire element
otherwise.
> -(defun map-elt (map key &optional default)
> +(defun map-elt (map key &optional default testfn)
> "Lookup KEY in MAP and return its associated value.
> If KEY is not found, return DEFAULT which defaults to nil.
>
> -If MAP is a list, `eql' is used to lookup KEY.
> +If MAP is a list, TESTFN is used to lookup KEY if non-nil or `eql' if nil.
Since the sentence references more than one argument, the "or `eql' if
nil" part is ambiguous. Suggest to disambiguate:
If MAP is a list, `eql' is used to lookup KEY. Optional argument
TESTFN, if non-nil, means use its function definition instead of
`eql'.
> -(defmacro map-put (map key value)
> +(defmacro map-put (map key value &optional testfn)
> "Associate KEY with VALUE in MAP and return VALUE.
> If KEY is already present in MAP, replace the associated value
> with VALUE.
> +When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'.
Likewise here.
> -(defun assoc-default (key alist &optional test default)
> +(defun assoc-default (key alist &optional test default full)
> "Find object KEY in a pseudo-alist ALIST.
> ALIST is a list of conses or objects. Each element
> (or the element's car, if it is a cons) is compared with KEY by
> calling TEST, with two arguments: (i) the element or its car,
> and (ii) KEY.
> If that is non-nil, the element matches; then `assoc-default'
> - returns the element's cdr, if it is a cons, or DEFAULT if the
> - element is not a cons.
> + returns the element, if it is a cons and FULL is non-nil,
> + or the element's cdr, if it is a cons and FULL is nil,
^^
That "it" is ambiguous: does it refer to "element" or to "cdr"?
> -(defun alist-get (key alist &optional default remove)
> - "Return the value associated with KEY in ALIST, using `assq'.
> +(defun alist-get (key alist &optional default remove testfn)
> + "Return the value associated with KEY in ALIST.
> If KEY is not found in ALIST, return DEFAULT.
> +Use TESTFN to lookup in the alist if non-nil. Otherwise, use `assq'.
Again, "if non-nil" is ambiguous: it could refer to TESTFN or to
alist.
> +@defun assoc-predicate key alist &optional pred
> +This function is like @code{assoc} in that it returns the first
> +association for @var{key} in @var{alist}, but if @code{pred} is
> +non-@code{nil}, then it makes the comparison using @code{pred}
> +instead of @code{equal}. @code{assoc-predicate} returns @code{nil}
> +if no association in @var{alist} has a @sc{car}, @var{x}, satisfying
> +@code{(funcall pred x key)}.
^^^^^^^^^^^^^^^^^^
"pred", "x", and "key" should be in @var here. I'd also include the
entire @code snippet in @w{..}, so that it won't be split between two
lines.
> ++++
> +** New defun 'assoc-predicate', like 'assoc' with an optional argument
> +PRED, a predicate to compare the elements in the alist.
Please use "function" in NEWS, not "defun".
> +(defun assoc-predicate (key alist &optional pred)
> + "Like `assoc' but compare keys with TEST."
^^^^
PRED, not TEST.
Thanks.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 08:10:02 GMT)
Full text and
rfc822 format available.
Message #50 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Tino Calancha <tino.calancha <at> gmail.com> writes:
> Nico, one thing worries me is the following:
> * After this patch, `map.el' v1.2 depends on Emacs version > 25:
> * because it makes a call to `alist-get' with 5 parameters i.e., it
> uses TESTFN.
> Is that a problem?
map.el is not distributed outside of Emacs, so it shouldn't be a
problem.
I plan to do a more or less complete rewrite of map.el based on the same
design I used in the rewrite of seq.el (using methods for dispatching).
Maybe then I'll distribute it in GNU ELPA as well, but that's something
to worry about later, and we can always find solutions :)
Cheers,
Nico
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 08:12:02 GMT)
Full text and
rfc822 format available.
Message #53 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Tino Calancha <tino.calancha <at> gmail.com> writes:
>> But wouldn't it be better if `assoc' took an optional testfn? I'm not
>> sure I like the `full' parameter in `assoc-default', and I think the
>> inconsistency of the return values between `assoc' and `assoc-default'
>> is already confusing.
> In fact, that would kill 2 birds in a shot.
I don't understand what you mean. Would it be a good thing to
kill these 2 birds? :-D
Cheers,
Nico
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 08:23:01 GMT)
Full text and
rfc822 format available.
Message #56 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Fri, 7 Jul 2017, Nicolas Petton wrote:
> Tino Calancha <tino.calancha <at> gmail.com> writes:
>
>>> But wouldn't it be better if `assoc' took an optional testfn? I'm not
>>> sure I like the `full' parameter in `assoc-default', and I think the
>>> inconsistency of the return values between `assoc' and `assoc-default'
>>> is already confusing.
>
>> In fact, that would kill 2 birds in a shot.
>
> I don't understand what you mean. Would it be a good thing to
> kill these 2 birds? :-D
It depends if you like to eat birds. They are lighther than beef.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 08:35:02 GMT)
Full text and
rfc822 format available.
Message #59 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Tino Calancha <tino.calancha <at> gmail.com> writes:
>> I don't understand what you mean. Would it be a good thing to
>> kill these 2 birds? :-D
> It depends if you like to eat birds. They are lighther than beef.
Now I'll have to explain to puzzled people sitting next to me why I was
laughing out loud while staring at my emails.
More seriously, could you explain what you meant?
Cheers,
Nico
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 15:50:02 GMT)
Full text and
rfc822 format available.
Message #62 received at 27584 <at> debbugs.gnu.org (full text, mbox):
> More seriously, could you explain what you meant?
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.
Stefan "damn birds!"
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 15:55:02 GMT)
Full text and
rfc822 format available.
Message #65 received at 27584 <at> debbugs.gnu.org (full text, mbox):
> + (declare (compiler-macro
> + (lambda (_)
> + `(pcase ,pred
> + ('eq (assq ,key ,alist))
> + ((or 'equal 'nil) (assoc ,key ,alist))
> + ((guard (and (macroexp-const-p ,key) (eq ,pred 'eql)))
> + (if (floatp ,key)
> + (assoc ,key ,alist) (assq ,key ,alist)))
> + (_ (assoc-default ,key ,alist ,pred nil 'full))))))
This replaces a call to the function with a chunk of code which does
`pcase`, which is not what we want: we want the `pcase` to be executed
during compilation and if we can't choose which branch to follow, then
we just keep the call unchanged (which is why, in my define-inline
example, the pcase was outside of `inline-quote`).
Stefan
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 15:56:01 GMT)
Full text and
rfc822 format available.
Message #68 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Stefan Monnier <monnier <at> 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.
Thank you, it's all clear now :)
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 07 Jul 2017 19:48:02 GMT)
Full text and
rfc822 format available.
Message #71 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Stefan Monnier <monnier <at> 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 <at> 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 (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Sat, 08 Jul 2017 06:31:01 GMT)
Full text and
rfc822 format available.
Message #74 received at 27584 <at> debbugs.gnu.org (full text, mbox):
> From: Nicolas Petton <nicolas <at> petton.fr>
> Date: Fri, 07 Jul 2017 21:47:03 +0200
> Cc: 27584 <at> debbugs.gnu.org, Tino Calancha <tino.calancha <at> gmail.com>
>
> + 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;
> + }
No need for braces when there's only one line to enclose.
Also, no need for parentheses around "!NILP (...)".
Bonus points for simplifying the code by determining TESTFN up front,
then having only one of the above two clauses.
Thanks.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Sat, 08 Jul 2017 07:03:02 GMT)
Full text and
rfc822 format available.
Message #77 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Sat, 8 Jul 2017, Eli Zaretskii wrote:
>> From: Nicolas Petton <nicolas <at> petton.fr>
>> Date: Fri, 07 Jul 2017 21:47:03 +0200
>> Cc: 27584 <at> debbugs.gnu.org, Tino Calancha <tino.calancha <at> gmail.com>
>>
>> + 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;
>> + }
>
> No need for braces when there's only one line to enclose.
> Also, no need for parentheses around "!NILP (...)".
>
> Bonus points for simplifying the code by determining TESTFN up front,
> then having only one of the above two clauses.
Do you mean something like this?
{
Lisp_Object tail = list;
Lisp_Object fn = NILP (testfn) ? Qequal : testfn;
FOR_EACH_TAIL (tail)
{
Lisp_Object car = XCAR (tail);
if (CONSP (car) && !NILP (call2 (fn, (XCAR (car)), key)))
return car;
}
CHECK_LIST_END (tail, list);
return Qnil;
}
;; This is shorter but now the default case, because the call2, is less
;; efficient than just using Fequal, right?
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Sat, 08 Jul 2017 07:16:02 GMT)
Full text and
rfc822 format available.
Message #80 received at 27584 <at> debbugs.gnu.org (full text, mbox):
> From: Tino Calancha <tino.calancha <at> gmail.com>
> Date: Sat, 8 Jul 2017 16:02:12 +0900 (JST)
> cc: Nicolas Petton <nicolas <at> petton.fr>, monnier <at> iro.umontreal.ca,
> 27584 <at> debbugs.gnu.org, Tino Calancha <tino.calancha <at> gmail.com>
>
> > Bonus points for simplifying the code by determining TESTFN up front,
> > then having only one of the above two clauses.
> Do you mean something like this?
>
> {
> Lisp_Object tail = list;
> Lisp_Object fn = NILP (testfn) ? Qequal : testfn;
> FOR_EACH_TAIL (tail)
> {
> Lisp_Object car = XCAR (tail);
> if (CONSP (car) && !NILP (call2 (fn, (XCAR (car)), key)))
> return car;
> }
>
> CHECK_LIST_END (tail, list);
> return Qnil;
> }
That's one way, yes. But not necessarily the one I had in mind.
> ;; This is shorter but now the default case, because the call2, is less
> ;; efficient than just using Fequal, right?
Is it? Did you time it?
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Sat, 08 Jul 2017 11:30:02 GMT)
Full text and
rfc822 format available.
Message #83 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Tino Calancha <tino.calancha <at> gmail.com> writes:
> Do you mean something like this?
>
> {
> Lisp_Object tail = list;
> Lisp_Object fn = NILP (testfn) ? Qequal : testfn;
> FOR_EACH_TAIL (tail)
> {
> Lisp_Object car = XCAR (tail);
> if (CONSP (car) && !NILP (call2 (fn, (XCAR (car)), key)))
> return car;
> }
>
> CHECK_LIST_END (tail, list);
> return Qnil;
> }
>
> ;; This is shorter but now the default case, because the call2, is less
> ;; efficient than just using Fequal, right?
I like your version more, but I also thought that it would be slower for
the default case.
I ran benchmark-run with the first version:
(setq alist (mapcar (lambda (e) `(,(intern e) . ,e))
(locate-file-completion-table
load-path (get-load-suffixes) "" nil t)))
(benchmark-run (assoc 'absent alist))
(0.00023356 0 0.0)
(0.00016584 0 0.0)
(0.000165243 0 0.0)
(0.000164741 0 0.0)
(0.000240754 0 0.0)
(0.000104102 0 0.0)
and with your version:
(0.000556587 0 0.0)
(0.000238677 0 0.0)
(0.000498506 0 0.0)
(0.000527675 0 0.0)
(0.00064989 0 0.0)
(0.000520543 0 0.0)
Cheers,
Nico
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Sat, 08 Jul 2017 11:33:01 GMT)
Full text and
rfc822 format available.
Message #86 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Eli Zaretskii <eliz <at> gnu.org> writes:
> That's one way, yes. But not necessarily the one I had in mind.
What solution did you have in mind?
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Sat, 08 Jul 2017 11:47:02 GMT)
Full text and
rfc822 format available.
Message #89 received at 27584 <at> debbugs.gnu.org (full text, mbox):
> From: Nicolas Petton <nicolas <at> petton.fr>
> Cc: monnier <at> iro.umontreal.ca, 27584 <at> debbugs.gnu.org
> Date: Sat, 08 Jul 2017 13:32:11 +0200
>
> > That's one way, yes. But not necessarily the one I had in mind.
>
> What solution did you have in mind?
Something like this:
FOR_EACH_TAIL (tail)
{
Lisp_Object car = XCAR (tail);
if (CONSP (car)
&& (NILP (testfn)
? (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key)))
: !NILP (call2 (testfn, XCAR (car), key))))
return car;
}
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Sun, 09 Jul 2017 14:47:02 GMT)
Full text and
rfc822 format available.
Message #92 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Fri, 7 Jul 2017, Stefan Monnier wrote:
>> + (declare (compiler-macro
>> + (lambda (_)
>> + `(pcase ,pred
>> + ('eq (assq ,key ,alist))
>> + ((or 'equal 'nil) (assoc ,key ,alist))
>> + ((guard (and (macroexp-const-p ,key) (eq ,pred 'eql)))
>> + (if (floatp ,key)
>> + (assoc ,key ,alist) (assq ,key ,alist)))
>> + (_ (assoc-default ,key ,alist ,pred nil 'full))))))
>
> This replaces a call to the function with a chunk of code which does
> `pcase`, which is not what we want: we want the `pcase` to be executed
> during compilation and if we can't choose which branch to follow, then
> we just keep the call unchanged (which is why, in my define-inline
> example, the pcase was outside of `inline-quote`).
Thank you Stefan. After playing a bit with this i'd like to
ask you something.
I rewrote it as follows:
(declare (compiler-macro
(lambda (form)
(pcase pred
(''eq `(assq ,key ,alist))
((or ''equal 'nil) `(assoc ,key ,alist))
((and (guard (macroexp-const-p key)) ''eql)
(if (floatp key)
`(assoc ,key ,alist) `(assq ,key ,alist)))
(t form)))))
Apparently, it works as a charm:
*) For example, if i compile a file with content:
;; -*- lexical-binding: t; -*-
(defun run ()
(assoc-predicate 999 '((1 . "a") (2 . "b")) 'eql))
*) tmp.elc contains, something like:
(defalias 'run #[0 "\300\301\236\207" [999 ((1 . "a") (2 . "b"))] 2])
**) But note what happens if the file contains:
;; -*- lexical-binding: t; -*-
(defun run ()
(assoc-predicate (let ((x 999)) x) '((1 . "a") (2 . "b")) 'eql))
**) tmp.elc shows:
(defalias 'run #[0 "\300\301\211\262\302\303#\207" [assoc-predicate 999
((1 . "a") (2 . "b")) eql] 4])
That is, in the pcase fails the condition:
(and (guard (macroexp-const-p key)) ''eql)
so that the compiler macro doesn't change the form.
But we know that:
(macroexp-const-p (let ((x 999)) x))
=> t
So, i would expect to **) compiles to similar code as *).
What is wrong with my assumptions?
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Sun, 09 Jul 2017 14:49:01 GMT)
Full text and
rfc822 format available.
Message #95 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Sat, 8 Jul 2017, Eli Zaretskii wrote:
>> From: Nicolas Petton <nicolas <at> petton.fr>
>> Cc: monnier <at> iro.umontreal.ca, 27584 <at> debbugs.gnu.org
>> Date: Sat, 08 Jul 2017 13:32:11 +0200
>>
>>> That's one way, yes. But not necessarily the one I had in mind.
>>
>> What solution did you have in mind?
>
> Something like this:
>
> FOR_EACH_TAIL (tail)
> {
> Lisp_Object car = XCAR (tail);
> if (CONSP (car)
> && (NILP (testfn)
> ? (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key)))
> : !NILP (call2 (testfn, XCAR (car), key))))
> return car;
> }
Nice!
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Sun, 09 Jul 2017 19:19:01 GMT)
Full text and
rfc822 format available.
Message #98 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Eli Zaretskii <eliz <at> gnu.org> writes:
>> What solution did you have in mind?
>
> Something like this:
>
> FOR_EACH_TAIL (tail)
> {
> Lisp_Object car = XCAR (tail);
> if (CONSP (car)
> && (NILP (testfn)
> ? (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key)))
> : !NILP (call2 (testfn, XCAR (car), key))))
> return car;
> }
Thanks, it's indeed much better.
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Mon, 10 Jul 2017 12:05:02 GMT)
Full text and
rfc822 format available.
Message #101 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Tino Calancha <tino.calancha <at> gmail.com> writes:
> But we know that:
> (macroexp-const-p (let ((x 999)) x))
> => t
Aren't you just missing a quote before the expression?
Michael.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Mon, 10 Jul 2017 12:29:01 GMT)
Full text and
rfc822 format available.
Message #104 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Mon, 10 Jul 2017, Michael Heerdegen wrote:
> Tino Calancha <tino.calancha <at> gmail.com> writes:
>
>> But we know that:
>> (macroexp-const-p (let ((x 999)) x))
>> => t
>
> Aren't you just missing a quote before the expression?
That's right, the compiler macro see '(let ((x 999))
that explains my example:
(macroexp-const-p '(let ((x 999)) x))
=> nil
I am a bit fooled by the docstring of `macroexp-const-p'.
"Return non-nil if EXP will always evaluate to the same value."
Consider the expression:
(setq exp '(let ((x 999)) x))
This will always be evaluated to 999:
(eval exp)
=> 999
Then, I would expect `macroexp-const-p' return non-nil
on this expressio, but it doesn't.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Mon, 10 Jul 2017 12:39:02 GMT)
Full text and
rfc822 format available.
Message #107 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Tino Calancha <tino.calancha <at> gmail.com> writes:
> I am a bit fooled by the docstring of `macroexp-const-p'.
> "Return non-nil if EXP will always evaluate to the same value."
Well, wouldn't a "correct" implementation solve the halting problem?
But yes, the doc is misleading.
Michael.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Mon, 10 Jul 2017 12:49:01 GMT)
Full text and
rfc822 format available.
Message #110 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Tino Calancha <tino.calancha <at> gmail.com> writes:
> I rewrote it as follows:
>
> (declare (compiler-macro
> (lambda (form)
> (pcase pred
> (''eq `(assq ,key ,alist))
> ((or ''equal 'nil) `(assoc ,key ,alist))
> ((and (guard (macroexp-const-p key)) ''eql)
> (if (floatp key)
> `(assoc ,key ,alist) `(assq ,key ,alist)))
> (t form)))))
Is this a good idea in general? PRED could also be function-quoted, or
a variable bound to `eq'. And KEY could be an expression that evaluates
to a float. That would fail the `floatp' test.
Michael.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Mon, 10 Jul 2017 12:51:02 GMT)
Full text and
rfc822 format available.
Message #113 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Tino Calancha <tino.calancha <at> gmail.com> writes:
> +(defun assoc-predicate (key alist &optional pred)
> + "Like `assoc' but compare keys with TEST."
^^^^
Nitpick: That should be "PRED".
Michael.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Mon, 10 Jul 2017 13:03:02 GMT)
Full text and
rfc822 format available.
Message #116 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Mon, 10 Jul 2017, Michael Heerdegen wrote:
> Tino Calancha <tino.calancha <at> gmail.com> writes:
>
>> I rewrote it as follows:
>>
>> (declare (compiler-macro
>> (lambda (form)
>> (pcase pred
>> (''eq `(assq ,key ,alist))
>> ((or ''equal 'nil) `(assoc ,key ,alist))
>> ((and (guard (macroexp-const-p key)) ''eql)
>> (if (floatp key)
>> `(assoc ,key ,alist) `(assq ,key ,alist)))
>> (t form)))))
>
> Is this a good idea in general? PRED could also be function-quoted, or
> a variable bound to `eq'. And KEY could be an expression that evaluates
> to a float. That would fail the `floatp' test.
Well, this code is now in the 'Limbo', because we are thinking
to use the Nico solution (`assoc' having an optional arg PRED).
That said, its fun to discuss about it.
You know, this compiler macro is inspired in the one used by
`cl-assoc' i.e., `cl--compiler-macro-assoc'. If you find a problem
on it, then the same problem might arise in `cl-assoc' :-S
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Mon, 10 Jul 2017 13:19:02 GMT)
Full text and
rfc822 format available.
Message #119 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Tino Calancha <tino.calancha <at> gmail.com> writes:
> > Is this a good idea in general? PRED could also be function-quoted,
> > or a variable bound to `eq'. And KEY could be an expression that
> > evaluates to a float. That would fail the `floatp' test.
> Well, this code is now in the 'Limbo', because we are thinking
> to use the Nico solution (`assoc' having an optional arg PRED).
> That said, its fun to discuss about it.
> You know, this compiler macro is inspired in the one used by
> `cl-assoc' i.e., `cl--compiler-macro-assoc'. If you find a problem
> on it, then the same problem might arise in `cl-assoc' :-S
I was wrong about your handling of KEY, I think it is ok.
For the PRED, `cl--compiler-macro-assoc' uses `cl--const-expr-val' that
DTRT for function quoting. The compile time optimization is limited but
doesn't look wrong.
Michael.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Tue, 11 Jul 2017 08:09:02 GMT)
Full text and
rfc822 format available.
Message #122 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Eli Zaretskii <eliz <at> gnu.org> writes:
> Something like this:
>
> FOR_EACH_TAIL (tail)
> {
> Lisp_Object car = XCAR (tail);
> if (CONSP (car)
> && (NILP (testfn)
> ? (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key)))
> : !NILP (call2 (testfn, XCAR (car), key))))
> return car;
> }
I installed your version in master.
Tino, would you like to adapt your patch to use the new assoc?
Cheers,
Nico
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Tue, 11 Jul 2017 09:21:02 GMT)
Full text and
rfc822 format available.
Message #125 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Nicolas Petton <nicolas <at> petton.fr> writes:
> Tino, would you like to adapt your patch to use the new assoc?
Here we are:
--8<-----------------------------cut here---------------start------------->8---
commit 2a9fb44ddae0acbd09c3123f06981d291163e765
Author: Tino Calancha <tino.calancha <at> gmail.com>
Date: Tue Jul 11 18:17:00 2017 +0900
alist-get: Add optional arg TESTFN
If TESTFN is non-nil, then it is the predicate to lookup
the alist. Otherwise, use 'eq' (Bug#27584).
* lisp/subr.el (alist-get): Add optional arg FULL.
* lisp/emacs-lisp/map.el (map-elt, map-put): Add optional arg TESTFN.
* lisp/emacs-lisp/gv.el (alist-get): Update expander.
* doc/lispref/lists.texi (Association Lists): Update manual.
* etc/NEWS: Announce the changes.
* test/lisp/emacs-lisp/map-tests.el (test-map-put-testfn-alist)
(test-map-elt-testfn): New tests.
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 966d8f18b1..39353b6de6 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1589,16 +1589,20 @@ Association Lists
@end smallexample
@end defun
-@defun alist-get key alist &optional default remove
-This function is like @code{assq}, but instead of returning the entire
-association for @var{key} in @var{alist},
-@w{@code{(@var{key} . @var{value})}}, it returns just the @var{value}.
-If @var{key} is not found in @var{alist}, it returns @var{default}.
-
-This is a generalized variable (@pxref{Generalized Variables}) that
-can be used to change a value with @code{setf}. When using it to set
-a value, optional argument @var{remove} non-@code{nil} means to remove
-@var{key} from @var{alist} if the new value is @code{eql} to @var{default}.
+@defun alist-get key alist &optional default remove testfn
+This function is similar to @code{assq}. It finds the first
+association @w{@code{(@var{key} . @var{value})}} by comparing
+@var{key} with @var{alist} elements, and, if found, returns the
+@var{value} of that association. If no association is found, the
+function returns @var{default}. Comparison of @var{key} against
+@var{alist} elements uses the function specified by @var{testfn},
+defaulting to @code{eq}.
+
+The return value is a generalized variable (@pxref{Generalized
+Variables}) that can be used to change a value with @code{setf}. When
+using it to set a value, optional argument @var{remove} non-@code{nil}
+means to remove @var{key}'s association from @var{alist} if the new
+value is @code{eql} to @var{default}.
@end defun
@defun rassq value alist
diff --git a/etc/NEWS b/etc/NEWS
index 68ebdb3c15..eb61e7d182 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1105,6 +1105,9 @@ break.
* Lisp Changes in Emacs 26.1
++++
+** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'.
+
** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2
contain the same elements, regardless of the order.
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index c5c12a6414..27376fc7f9 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -377,10 +377,12 @@ setf
`(with-current-buffer ,buf (set (make-local-variable ,var) ,v))))
(gv-define-expander alist-get
- (lambda (do key alist &optional default remove)
+ (lambda (do key alist &optional default remove testfn)
(macroexp-let2 macroexp-copyable-p k key
(gv-letplace (getter setter) alist
- (macroexp-let2 nil p `(assq ,k ,getter)
+ (macroexp-let2 nil p `(if (and ,testfn (not (eq ,testfn 'eq)))
+ (assoc ,k ,getter ,testfn)
+ (assq ,k ,getter))
(funcall do (if (null default) `(cdr ,p)
`(if ,p (cdr ,p) ,default))
(lambda (v)
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index a89457e877..31ba075c40 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -4,7 +4,7 @@
;; Author: Nicolas Petton <nicolas <at> petton.fr>
;; Keywords: convenience, map, hash-table, alist, array
-;; Version: 1.1
+;; Version: 1.2
;; Package: map
;; Maintainer: emacs-devel <at> gnu.org
@@ -93,11 +93,13 @@ map-let
((arrayp ,map-var) ,(plist-get args :array))
(t (error "Unsupported map: %s" ,map-var)))))
-(defun map-elt (map key &optional default)
+(defun map-elt (map key &optional default testfn)
"Lookup KEY in MAP and return its associated value.
If KEY is not found, return DEFAULT which defaults to nil.
-If MAP is a list, `eql' is used to lookup KEY.
+If MAP is a list, `eql' is used to lookup KEY. Optional argument
+TESTFN, if non-nil, means use its function definition instead of
+`eql'.
MAP can be a list, hash-table or array."
(declare
@@ -106,30 +108,33 @@ map-elt
(gv-letplace (mgetter msetter) `(gv-delay-error ,map)
(macroexp-let2* nil
;; Eval them once and for all in the right order.
- ((key key) (default default))
+ ((key key) (default default) (testfn testfn))
`(if (listp ,mgetter)
;; Special case the alist case, since it can't be handled by the
;; map--put function.
,(gv-get `(alist-get ,key (gv-synthetic-place
,mgetter ,msetter)
- ,default)
+ ,default nil ,testfn)
do)
,(funcall do `(map-elt ,mgetter ,key ,default)
(lambda (v) `(map--put ,mgetter ,key ,v)))))))))
(map--dispatch map
- :list (alist-get key map default)
+ :list (alist-get key map default nil testfn)
:hash-table (gethash key map default)
:array (if (and (>= key 0) (< key (seq-length map)))
(seq-elt map key)
default)))
-(defmacro map-put (map key value)
+(defmacro map-put (map key value &optional testfn)
"Associate KEY with VALUE in MAP and return VALUE.
If KEY is already present in MAP, replace the associated value
with VALUE.
+When MAP is a list, test equality with TESTFN if non-nil, otherwise use `eql'.
+TESTFN, if non-nil, means use its function definition instead of
+`eql'.
MAP can be a list, hash-table or array."
- `(setf (map-elt ,map ,key) ,value))
+ `(setf (map-elt ,map ,key nil ,testfn) ,value))
(defun map-delete (map key)
"Delete KEY from MAP and return MAP.
diff --git a/lisp/subr.el b/lisp/subr.el
index a9edff6166..d9d918ed12 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -725,15 +725,18 @@ rassq-delete-all
(setq tail tail-cdr))))
alist)
-(defun alist-get (key alist &optional default remove)
- "Return the value associated with KEY in ALIST, using `assq'.
+(defun alist-get (key alist &optional default remove testfn)
+ "Return the value associated with KEY in ALIST.
If KEY is not found in ALIST, return DEFAULT.
+Use TESTFN to lookup in the alist if non-nil. Otherwise, use `assq'.
This is a generalized variable suitable for use with `setf'.
When using it to set a value, optional argument REMOVE non-nil
means to remove KEY from ALIST if the new value is `eql' to DEFAULT."
(ignore remove) ;;Silence byte-compiler.
- (let ((x (assq key alist)))
+ (let ((x (if (not testfn)
+ (assq key alist)
+ (assoc key alist testfn))))
(if x (cdr x) default)))
(defun remove (elt seq)
diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el
index 07e85cc539..15b0655040 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -63,6 +63,11 @@ with-maps-do
(with-maps-do map
(should (= 5 (map-elt map 7 5)))))
+(ert-deftest test-map-elt-testfn ()
+ (let ((map (list (cons "a" 1) (cons "b" 2))))
+ (should-not (map-elt map "a"))
+ (should (map-elt map "a" nil 'equal))))
+
(ert-deftest test-map-elt-with-nil-value ()
(should (null (map-elt '((a . 1)
(b))
@@ -94,6 +99,13 @@ with-maps-do
(should (eq (map-elt alist 2)
'b))))
+(ert-deftest test-map-put-testfn-alist ()
+ (let ((alist (list (cons "a" 1) (cons "b" 2))))
+ (map-put alist "a" 3 'equal)
+ (should-not (cddr alist))
+ (map-put alist "a" 9)
+ (should (cddr alist))))
+
(ert-deftest test-map-put-return-value ()
(let ((ht (make-hash-table)))
(should (eq (map-put ht 'a 'hello) 'hello))))
--8<-----------------------------cut here---------------end--------------->8---
In GNU Emacs 26.0.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.22.11)
of 2017-07-11
Repository revision: 0bece6c6815cc59e181817a2765a4ea752f34f56
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Wed, 12 Jul 2017 17:37:02 GMT)
Full text and
rfc822 format available.
Message #128 received at 27584 <at> debbugs.gnu.org (full text, mbox):
Tino Calancha <tino.calancha <at> gmail.com> writes:
> -@defun alist-get key alist &optional default remove
> [...]
> -This is a generalized variable (@pxref{Generalized Variables}) that
> +The return value is a generalized variable (@pxref{Generalized
I don't think this is good wording. When `alist-get' returns 1, do we
really want to call `1' a generalized variable?
What is settable is the place (expression), so I think we instead call
the expression of the function call "generalized variable".
Michael.
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 14 Jul 2017 05:20:01 GMT)
Full text and
rfc822 format available.
Message #131 received at 27584 <at> debbugs.gnu.org (full text, mbox):
On Wed, 12 Jul 2017, Michael Heerdegen wrote:
> Tino Calancha <tino.calancha <at> gmail.com> writes:
>
>> -@defun alist-get key alist &optional default remove
>> [...]
>> -This is a generalized variable (@pxref{Generalized Variables}) that
>> +The return value is a generalized variable (@pxref{Generalized
>
> I don't think this is good wording. When `alist-get' returns 1, do we
> really want to call `1' a generalized variable?
>
> What is settable is the place (expression), so I think we instead call
> the expression of the function call "generalized variable".
thank you, agreed.
I will keep the original:
'This is a generalized variable ...'
instead of:
'The return value is a ...'
I will push it in a few days if there are no issues to address.
Tino
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Fri, 14 Jul 2017 11:17:01 GMT)
Full text and
rfc822 format available.
Message #134 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Tino Calancha <tino.calancha <at> gmail.com> writes:
> I will push it in a few days if there are no issues to address.
Great, thanks!
Nico
[signature.asc (application/pgp-signature, inline)]
Reply sent
to
Tino Calancha <tino.calancha <at> gmail.com>:
You have taken responsibility.
(Mon, 17 Jul 2017 13:39:02 GMT)
Full text and
rfc822 format available.
Notification sent
to
Tino Calancha <tino.calancha <at> gmail.com>:
bug acknowledged by developer.
(Mon, 17 Jul 2017 13:39:02 GMT)
Full text and
rfc822 format available.
Message #139 received at 27584-done <at> debbugs.gnu.org (full text, mbox):
Nicolas Petton <nicolas <at> petton.fr> writes:
> Tino Calancha <tino.calancha <at> gmail.com> writes:
>
>> I will push it in a few days if there are no issues to address.
Implemented in master branch as commit 76e1f7d00fbff7bf8183ba85db2f67a11aa2d5ce
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Tue, 01 Aug 2017 16:38:01 GMT)
Full text and
rfc822 format available.
Message #142 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Nicolas Petton <nicolas <at> petton.fr> writes:
> Eli Zaretskii <eliz <at> gnu.org> writes:
>
>> Something like this:
>>
>> FOR_EACH_TAIL (tail)
>> {
>> Lisp_Object car = XCAR (tail);
>> if (CONSP (car)
>> && (NILP (testfn)
>> ? (EQ (XCAR (car), key) || !NILP (Fequal (XCAR (car), key)))
>> : !NILP (call2 (testfn, XCAR (car), key))))
>> return car;
>> }
>
> I installed your version in master.
Here's another patch that adds a similar `testfn' parameter to `rassoc':
From 103f7a5cdd80961e654fca879aba1b9a67d4eb22 Mon Sep 17 00:00:00 2001
From: Nicolas Petton <nicolas <at> petton.fr>
Date: Tue, 1 Aug 2017 18:29:34 +0200
Subject: [PATCH] Add an optional testfn parameter to rassoc
* src/fns.c (rassoc): Add an optional testfn parameter. When non-nil,
use this parameter for comparison instead of equal.
* src/fontset.c (fs_query_fontset): Update usage of Frassoc.
* test/src/fns-tests.el (test-rassoc-tesfn): Add unit tests for the
new testfn parameter.
* etc/NEWS:
* doc/lispref/lists.texi: Document the change.
---
doc/lispref/lists.texi | 6 ++++--
etc/NEWS | 3 ++-
src/fns.c | 15 ++++++++++-----
src/fontset.c | 2 +-
test/src/fns-tests.el | 6 ++++++
5 files changed, 23 insertions(+), 9 deletions(-)
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 0c99380682..321246de12 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1550,8 +1550,10 @@ Association Lists
@defun rassoc value alist
This function returns the first association with value @var{value} in
-@var{alist}. It returns @code{nil} if no association in @var{alist} has
-a @sc{cdr} @code{equal} to @var{value}.
+@var{alist}, comparing @var{key} against the alist elements using
+@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{cdr} @code{equal} to @var{value}.
@code{rassoc} is like @code{assoc} except that it compares the @sc{cdr} of
each @var{alist} association instead of the @sc{car}. You can think of
diff --git a/etc/NEWS b/etc/NEWS
index 44f5ff5bde..50734b846f 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -105,7 +105,8 @@ The effect is similar to that of "toolBar" resource on the tool bar.
* Changes in Emacs 26.1
+++
-** The function 'assoc' now takes an optional third argument 'testfn'.
+** The functions 'assoc' and 'rassoc ' now take an optional third
+argument 'testfn'.
This argument, when non-nil, is used for comparison instead of
'equal'.
diff --git a/src/fns.c b/src/fns.c
index d849618f2b..9e7d47253f 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -1474,17 +1474,22 @@ The value is actually the first element of LIST whose cdr is KEY. */)
return Qnil;
}
-DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
- doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
-The value is actually the first element of LIST whose cdr equals KEY. */)
- (Lisp_Object key, Lisp_Object list)
+DEFUN ("rassoc", Frassoc, Srassoc, 2, 3, 0,
+ doc: /* Return non-nil if KEY is equal to the cdr of an element of LIST.
+The value is actually the first element of LIST whose cdr equals KEY.
+
+Equality is defined by TESTFN is 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 (XCDR (car), key) || !NILP (Fequal (XCDR (car), key))))
+ && (NILP (testfn)
+ ? (EQ (XCDR (car), key) || !NILP (Fequal
+ (XCDR (car), key)))
+ : !NILP (call2 (testfn, XCDR (car), key))))
return car;
}
CHECK_LIST_END (tail, list);
diff --git a/src/fontset.c b/src/fontset.c
index 74018060b8..4666b607ba 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -1184,7 +1184,7 @@ fs_query_fontset (Lisp_Object name, int name_pattern)
name = Fdowncase (name);
if (name_pattern != 1)
{
- tem = Frassoc (name, Vfontset_alias_alist);
+ tem = Frassoc (name, Vfontset_alias_alist, Qnil);
if (NILP (tem))
tem = Fassoc (name, Vfontset_alias_alist, Qnil);
if (CONSP (tem) && STRINGP (XCAR (tem)))
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index e294859226..83d7935a41 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -379,6 +379,12 @@ dot2
(should (eq (assoc "b" alist #'string-equal) (cadr alist)))
(should-not (assoc "b" alist #'eq))))
+(ert-deftest test-rassoc-testfn ()
+ (let ((alist '((a . "1") (b . "2"))))
+ (should-not (rassoc "1" alist #'ignore))
+ (should (eq (rassoc "2" alist #'string-equal) (cadr alist)))
+ (should-not (rassoc "2" alist #'eq))))
+
(ert-deftest test-cycle-rassq ()
(let ((c1 (cyc1 '(0 . 1)))
(c2 (cyc2 '(0 . 1) '(0 . 2)))
--
2.13.3
Cheers,
Nico
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Tue, 01 Aug 2017 16:50:01 GMT)
Full text and
rfc822 format available.
Message #145 received at 27584 <at> debbugs.gnu.org (full text, mbox):
[Message part 1 (text/plain, inline)]
Nicolas Petton <nicolas <at> petton.fr> writes:
> Here's another patch that adds a similar `testfn' parameter to
> `rassoc':
See the updated patch below which fixes the documentation:
From 00bd0ef08a9cbb68adbdc5add1f45d8234887d6e Mon Sep 17 00:00:00 2001
From: Nicolas Petton <nicolas <at> petton.fr>
Date: Tue, 1 Aug 2017 18:29:34 +0200
Subject: [PATCH] Add an optional testfn parameter to rassoc
* src/fns.c (rassoc): Add an optional testfn parameter. When non-nil,
use this parameter for comparison instead of equal.
* src/fontset.c (fs_query_fontset): Update usage of Frassoc.
* test/src/fns-tests.el (test-rassoc-tesfn): Add unit tests for the
new testfn parameter.
* etc/NEWS:
* doc/lispref/lists.texi: Document the change.
---
doc/lispref/lists.texi | 8 +++++---
etc/NEWS | 3 ++-
src/fns.c | 15 ++++++++++-----
src/fontset.c | 2 +-
test/src/fns-tests.el | 6 ++++++
5 files changed, 24 insertions(+), 10 deletions(-)
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 0c99380682..49913294f7 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1548,10 +1548,12 @@ Association Lists
that it ignores certain differences between strings. @xref{Text
Comparison}.
-@defun rassoc value alist
+@defun rassoc value alist &optional testfn
This function returns the first association with value @var{value} in
-@var{alist}. It returns @code{nil} if no association in @var{alist} has
-a @sc{cdr} @code{equal} to @var{value}.
+@var{alist}, comparing @var{value} against the alist elements using
+@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{cdr} equal to @var{value}.
@code{rassoc} is like @code{assoc} except that it compares the @sc{cdr} of
each @var{alist} association instead of the @sc{car}. You can think of
diff --git a/etc/NEWS b/etc/NEWS
index 44f5ff5bde..8662766426 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -105,7 +105,8 @@ The effect is similar to that of "toolBar" resource on the tool bar.
* Changes in Emacs 26.1
+++
-** The function 'assoc' now takes an optional third argument 'testfn'.
+** The functions 'assoc' and 'rassoc' now take an optional third
+argument 'testfn'.
This argument, when non-nil, is used for comparison instead of
'equal'.
diff --git a/src/fns.c b/src/fns.c
index d849618f2b..9e7d47253f 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -1474,17 +1474,22 @@ The value is actually the first element of LIST whose cdr is KEY. */)
return Qnil;
}
-DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0,
- doc: /* Return non-nil if KEY is `equal' to the cdr of an element of LIST.
-The value is actually the first element of LIST whose cdr equals KEY. */)
- (Lisp_Object key, Lisp_Object list)
+DEFUN ("rassoc", Frassoc, Srassoc, 2, 3, 0,
+ doc: /* Return non-nil if KEY is equal to the cdr of an element of LIST.
+The value is actually the first element of LIST whose cdr equals KEY.
+
+Equality is defined by TESTFN is 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 (XCDR (car), key) || !NILP (Fequal (XCDR (car), key))))
+ && (NILP (testfn)
+ ? (EQ (XCDR (car), key) || !NILP (Fequal
+ (XCDR (car), key)))
+ : !NILP (call2 (testfn, XCDR (car), key))))
return car;
}
CHECK_LIST_END (tail, list);
diff --git a/src/fontset.c b/src/fontset.c
index 74018060b8..4666b607ba 100644
--- a/src/fontset.c
+++ b/src/fontset.c
@@ -1184,7 +1184,7 @@ fs_query_fontset (Lisp_Object name, int name_pattern)
name = Fdowncase (name);
if (name_pattern != 1)
{
- tem = Frassoc (name, Vfontset_alias_alist);
+ tem = Frassoc (name, Vfontset_alias_alist, Qnil);
if (NILP (tem))
tem = Fassoc (name, Vfontset_alias_alist, Qnil);
if (CONSP (tem) && STRINGP (XCAR (tem)))
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index e294859226..83d7935a41 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -379,6 +379,12 @@ dot2
(should (eq (assoc "b" alist #'string-equal) (cadr alist)))
(should-not (assoc "b" alist #'eq))))
+(ert-deftest test-rassoc-testfn ()
+ (let ((alist '((a . "1") (b . "2"))))
+ (should-not (rassoc "1" alist #'ignore))
+ (should (eq (rassoc "2" alist #'string-equal) (cadr alist)))
+ (should-not (rassoc "2" alist #'eq))))
+
(ert-deftest test-cycle-rassq ()
(let ((c1 (cyc1 '(0 . 1)))
(c2 (cyc2 '(0 . 1) '(0 . 2)))
--
2.13.3
[signature.asc (application/pgp-signature, inline)]
Information forwarded
to
bug-gnu-emacs <at> gnu.org:
bug#27584; Package
emacs.
(Tue, 01 Aug 2017 18:55:01 GMT)
Full text and
rfc822 format available.
Message #148 received at 27584 <at> debbugs.gnu.org (full text, mbox):
> From: Nicolas Petton <nicolas <at> petton.fr>
> Cc: tino.calancha <at> gmail.com, 27584 <at> debbugs.gnu.org, monnier <at> iro.umontreal.ca
> Date: Tue, 01 Aug 2017 18:49:43 +0200
>
A few comments:
> * doc/lispref/lists.texi: Document the change.
This should state the node in parentheses (as if it were a function).
> +@defun rassoc value alist &optional testfn
> This function returns the first association with value @var{value} in
> -@var{alist}. It returns @code{nil} if no association in @var{alist} has
> -a @sc{cdr} @code{equal} to @var{value}.
> +@var{alist}, comparing @var{value} against the alist elements using
> +@var{testfn} if non-nil, or @code{equal} if nil (@pxref{Equality
The "if nil" part is confusing, because you actually mean "if
@var{testfn} is nil".
Also, "nil" should be in @code.
> +Predicates}). It returns @code{nil} if no association in @var{alist}
> +has a @sc{cdr} equal to @var{value}.
That reference to cdr is a surprise. the original description talked
about cdr right from the start, but the new one doesn't.
Thanks.
bug archived.
Request was from
Debbugs Internal Request <help-debbugs <at> gnu.org>
to
internal_control <at> debbugs.gnu.org.
(Wed, 30 Aug 2017 11:24:05 GMT)
Full text and
rfc822 format available.
This bug report was last modified 6 years and 241 days ago.
Previous Next
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.