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: Wed, 05 Jul 2017 12:22:44 +0900 Message-ID: <87tw2rva7v.fsf@calancha-pc> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain X-Trace: blaine.gmane.org 1499225065 1778 195.159.176.226 (5 Jul 2017 03:24:25 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Wed, 5 Jul 2017 03:24:25 +0000 (UTC) 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 Wed Jul 05 05:24: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 1dSavE-0008H3-RI for geb-bug-gnu-emacs@m.gmane.org; Wed, 05 Jul 2017 05:24:13 +0200 Original-Received: from localhost ([::1]:43863 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dSavJ-0000Q7-EP for geb-bug-gnu-emacs@m.gmane.org; Tue, 04 Jul 2017 23:24:17 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:39306) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dSavC-0000MB-LN for bug-gnu-emacs@gnu.org; Tue, 04 Jul 2017 23:24:13 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dSav8-0002vN-CX for bug-gnu-emacs@gnu.org; Tue, 04 Jul 2017 23:24:10 -0400 Original-Received: from debbugs.gnu.org ([208.118.235.43]:50124) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dSav8-0002ul-7Z for bug-gnu-emacs@gnu.org; Tue, 04 Jul 2017 23:24:06 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dSav4-0007ab-Nu; Tue, 04 Jul 2017 23:24:02 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Tino Calancha Original-Sender: "Debbugs-submit" Resent-CC: nicolas@petton.fr, monnier@iro.umontreal.ca, bug-gnu-emacs@gnu.org Resent-Date: Wed, 05 Jul 2017 03:24:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 27584 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: X-Debbugs-Original-To: bug-gnu-emacs@gnu.org X-Debbugs-Original-Xcc: nicolas petton , stefan monnier Original-Received: via spool by submit@debbugs.gnu.org id=B.149922498929108 (code B ref -1); Wed, 05 Jul 2017 03:24:02 +0000 Original-Received: (at submit) by debbugs.gnu.org; 5 Jul 2017 03:23:09 +0000 Original-Received: from localhost ([127.0.0.1]:52798 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dSauC-0007ZQ-IW for submit@debbugs.gnu.org; Tue, 04 Jul 2017 23:23:09 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:48228) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1dSauA-0007Yo-9f for submit@debbugs.gnu.org; Tue, 04 Jul 2017 23:23:06 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dSau3-0000dn-7Q for submit@debbugs.gnu.org; Tue, 04 Jul 2017 23:23:01 -0400 Original-Received: from lists.gnu.org ([2001:4830:134:3::11]:44744) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1dSau3-0000da-3a for submit@debbugs.gnu.org; Tue, 04 Jul 2017 23:22:59 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:39199) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dSau1-00082l-5e for bug-gnu-emacs@gnu.org; Tue, 04 Jul 2017 23:22:58 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dSatw-0000Pe-Pl for bug-gnu-emacs@gnu.org; Tue, 04 Jul 2017 23:22:57 -0400 Original-Received: from mail-pf0-x231.google.com ([2607:f8b0:400e:c00::231]:32898) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dSatw-0000Kd-GW for bug-gnu-emacs@gnu.org; Tue, 04 Jul 2017 23:22:52 -0400 Original-Received: by mail-pf0-x231.google.com with SMTP id e7so122681700pfk.0 for ; Tue, 04 Jul 2017 20:22:50 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:subject:date:message-id:mime-version; bh=ca7T+nt0v2zjbIL7wW6Qe1QKH/NfwVsjFFHXXKt9tPs=; b=WCYAMqTGWPYPBG8U1uwihs3iJy/h3MgaQ3y3eXeWqYxQE6oYTzNOlPB6csiVm0lGfW 5+Ciq5/mfgX9n/aCUhXyRAG45F/Poi0roTN5Jlq8MGK7ZWjc16qA2E5RyHvj8+fKBdNs +OowHLAagRCNesHGKtENYLLsq1IIaE80Dju2TVnrUUrTMlOKpP9ssKHyB4zkYo6by4Km MclnqHRVdmPsBHMFCmKmWrrxOil0XWL75hav8zVNMSxwo7t3X8Pv9KXKRiuIQ0LCwjQP Tkl6qv12C24aVjmtTvrxyVTGhZXm08UWPSdVSp5HOhdLjOALyABvv9+/vWokHs71t1pt 9gww== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:subject:date:message-id:mime-version; bh=ca7T+nt0v2zjbIL7wW6Qe1QKH/NfwVsjFFHXXKt9tPs=; b=j8XvxeSsqisY6cfeG+LcZREuEJ7RB7BLxDmgg2QSrODbogdDxw/xSqB/4wFiCK0zOH 4XE69+vc/unm9bB5CwVqmTsqBUl4Nc7FMqVo1tsQoNBhBtdtbS/I7ObxU2lrefpxvYgF HsIo6bmtFjEQUq6t9Ne4+T57TuZnuA/JcT8/JML2NXfDbW5+TmTIkObrBttHjE40SpH1 Hs0sUzzQWPW5+7js2XerqvQOHqosey/0DLRGV5ax8ePZ+iNUPkd0VQaUPG/oDTuYb7bW sgxODdBr7K8b4VoDXz7lq2x0EyZjH1yF6Q9vheRHKt3foFHCCMkJ+7D+T12G/HpK7ojS I9Ww== X-Gm-Message-State: AIVw110RhuaXIgvmfMnaKOoJNbPZPCV1/3ORyxepOReTqE+9tt0Pujyy jkBapH1T6dtBNKl3 X-Received: by 10.84.176.131 with SMTP id v3mr19936664plb.142.1499224969464; Tue, 04 Jul 2017 20:22:49 -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 s123sm49575649pgs.2.2017.07.04.20.22.47 for (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Tue, 04 Jul 2017 20:22:48 -0700 (PDT) X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x 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:134195 Archived-At: Severity: wishlist X-Debbugs-CC: Nicolas Petton , Stefan Monnier 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 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