From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Tino Calancha Newsgroups: gmane.emacs.bugs Subject: bug#27584: 26.0.50; alist-get: Add optional arg TESTFN Date: Thu, 06 Jul 2017 15:05:12 +0900 Message-ID: <87y3s2m76v.fsf@calancha-pc> References: <87tw2rva7v.fsf@calancha-pc> <87mv8j6y1z.fsf@petton.fr> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: blaine.gmane.org 1499321185 3938 195.159.176.226 (6 Jul 2017 06:06:25 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Thu, 6 Jul 2017 06:06:25 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.0.50 (gnu/linux) Cc: Nicolas Petton , stefan monnier To: 27584@debbugs.gnu.org Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Thu Jul 06 08:06:16 2017 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dSzvX-0000Nd-9z for geb-bug-gnu-emacs@m.gmane.org; Thu, 06 Jul 2017 08:06:11 +0200 Original-Received: from localhost ([::1]:49395 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dSzvc-0006Hg-JY for geb-bug-gnu-emacs@m.gmane.org; Thu, 06 Jul 2017 02:06:16 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:35259) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dSzvT-0006Ha-59 for bug-gnu-emacs@gnu.org; Thu, 06 Jul 2017 02:06:09 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dSzvO-0001Hk-4g for bug-gnu-emacs@gnu.org; Thu, 06 Jul 2017 02:06:07 -0400 Original-Received: from debbugs.gnu.org ([208.118.235.43]:51401) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dSzvN-0001HG-Vh for bug-gnu-emacs@gnu.org; Thu, 06 Jul 2017 02:06:02 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dSzvN-0006qs-OZ for bug-gnu-emacs@gnu.org; Thu, 06 Jul 2017 02:06:01 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Tino Calancha Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Thu, 06 Jul 2017 06:06:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 27584 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: Original-Received: via spool by 27584-submit@debbugs.gnu.org id=B27584.149932113226302 (code B ref 27584); Thu, 06 Jul 2017 06:06:01 +0000 Original-Received: (at 27584) by debbugs.gnu.org; 6 Jul 2017 06:05:32 +0000 Original-Received: from localhost ([127.0.0.1]:54078 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dSzut-0006qA-Qq for submit@debbugs.gnu.org; Thu, 06 Jul 2017 02:05:32 -0400 Original-Received: from mail-pg0-f66.google.com ([74.125.83.66]:34317) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dSzur-0006pw-Ls for 27584@debbugs.gnu.org; Thu, 06 Jul 2017 02:05:30 -0400 Original-Received: by mail-pg0-f66.google.com with SMTP id j186so1530226pge.1 for <27584@debbugs.gnu.org>; Wed, 05 Jul 2017 23:05:29 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version; bh=qEr+Qtbn110bsDPhX6KYPskbkh6W8kk57klvGj8wIjQ=; b=XPXH0/nA71h/AEAfOWYskhcId3FRFohpQQOyZ+V/C99ndWLEKDfpZX7KzIcH3YLKS1 JOZyc7zZ85srm7KlhHL0xZsbClevKF7yfSgYK/UoQ5goDLZu+LO9nnivAgmRsZ04J6+v G9oodrdltM25EfjDmaQxefuTZerSWC+s4NaQ64peYu/HOWzYO6yStnqMlY+d3j5QMoea uQhza5KAsPAN/Gssn2aD6wgoLMX18+iLHSUDZqh5zNuqh+CXxfL2ibrLTLVuZg77wozw t7fSgrAwvFqFMZfew4ckCh/f8hoU+ZSVmhzTHl/0N7vWsIsgPrQkXuPDJvpf5VWcipY5 Xfog== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:references:date:in-reply-to :message-id:user-agent:mime-version; bh=qEr+Qtbn110bsDPhX6KYPskbkh6W8kk57klvGj8wIjQ=; b=dROOh2Pqh4NoW1I7gEAyR1xTFVInhcCqzz9L/Ll9y1vB9Bxsttq5AHdXTFEb3Uznq4 1lkREKiuh51FPEZ+ITDh9nlwNNNZaEaAM2CJBj0/c2KgTRsmx61Kn0w4ahdexvDUWDN2 JcKwo6p5NZnb3Zd2odTPwdmsGLTvb2GG3D9XXmudG2EM5MZdZ8S2gAESYsMInUx83kq8 qVuwZi41KhFkJNJP8WIbV1PCnEwmBcfSS2HrmAMBExBBWjwrZlTDC85vkX+ZSCI3YlRD QzXVR6neWXP2OH9lZmXXvDVj41U3ZkSjbWXsv+uW4ExhwpLGETmULGVQOBpJTEE1yv0L kaxQ== X-Gm-Message-State: AIVw111B47ZuBii0f2goVF3DJrtQiJXkvhYM+KP0bFWlRRMw4OMPmHzc tsR73JyhiiepNQ== X-Received: by 10.99.56.21 with SMTP id f21mr24215815pga.235.1499321123208; Wed, 05 Jul 2017 23:05:23 -0700 (PDT) Original-Received: from calancha-pc (222.139.137.133.dy.bbexcite.jp. [133.137.139.222]) by smtp.gmail.com with ESMTPSA id e90sm2095119pfd.75.2017.07.05.23.05.20 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Wed, 05 Jul 2017 23:05:22 -0700 (PDT) In-Reply-To: (Tino Calancha's message of "Wed, 5 Jul 2017 22:18:53 +0900 (JST)") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:134243 Archived-At: Tino Calancha 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 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 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