From 9824885fabea53f8c4461d038f4c1edad1b8f591 Mon Sep 17 00:00:00 2001
From: tino calancha <tino.calancha@gmail.com>
Date: Sun, 28 Jan 2018 13:05:54 +0900
Subject: [PATCH] Code refactoring assoc-delete-all assq-delete-all
* lisp/subr.el (assoc-delete-all): Add optional arg TEST.
(assq-delete-all): Use assoc-delete-all.
* test/lisp/subr-tests.el (subr-tests--assoc-delete-all)
(subr-tests--assq-delete-all): New tests.
* doc/lispref/lists.texi (Association Lists): Document
assoc-delete-all in the manual.
; * etc/NEWS: Announce assoc-delete-all.
---
doc/lispref/lists.texi | 8 ++++++++
etc/NEWS | 3 +++
lisp/subr.el | 21 +++++++--------------
test/lisp/subr-tests.el | 20 +++++++++++++++++++-
4 files changed, 37 insertions(+), 15 deletions(-)
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 3e2dd13c706..761750eb20c 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1733,6 +1733,14 @@ alist
@end example
@end defun
+@defun assoc-delete-all key alist &optional test
+This function is like @code{assq-delete-all} except that it accepts
+an optional argument @var{test}, a predicate function to compare the
+keys in @var{alist}. If omitted or @code{nil}, @var{test} defaults to
+@code{equal}. As @code{assq-delete-all}, this function often modifies
+the original list structure of @var{alist}.
+@end defun
+
@defun rassq-delete-all value alist
This function deletes from @var{alist} all the elements whose @sc{cdr}
is @code{eq} to @var{value}. It returns the shortened alist, and
diff --git a/etc/NEWS b/etc/NEWS
index 27bde2d147c..2888acd4dcb 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -223,6 +223,9 @@ as new-style, bind the new variable 'force-new-style-backquotes' to t.
* Lisp Changes in Emacs 27.1
++++
+** New function assoc-delete-all.
+
** 'print-quoted' now defaults to t, so if you want to see
(quote x) instead of 'x you will have to bind it to nil where applicable.
diff --git a/lisp/subr.el b/lisp/subr.el
index 092850a44d9..e7a0ffc5bea 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -705,17 +705,19 @@ Non-strings in LIST are ignored."
(setq list (cdr list)))
list)
-(defun assoc-delete-all (key alist)
- "Delete from ALIST all elements whose car is `equal' to KEY.
+(defun assoc-delete-all (key alist &optional test)
+ "Delete from ALIST all elements whose car is KEY.
+Compare keys with TEST. Defaults to `equal'.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
+ (unless test (setq test #'equal))
(while (and (consp (car alist))
- (equal (car (car alist)) key))
+ (funcall test (caar alist) key))
(setq alist (cdr alist)))
(let ((tail alist) tail-cdr)
(while (setq tail-cdr (cdr tail))
(if (and (consp (car tail-cdr))
- (equal (car (car tail-cdr)) key))
+ (funcall test (caar tail-cdr) key))
(setcdr tail (cdr tail-cdr))
(setq tail tail-cdr))))
alist)
@@ -724,16 +726,7 @@ Elements of ALIST that are not conses are ignored."
"Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
Elements of ALIST that are not conses are ignored."
- (while (and (consp (car alist))
- (eq (car (car alist)) key))
- (setq alist (cdr alist)))
- (let ((tail alist) tail-cdr)
- (while (setq tail-cdr (cdr tail))
- (if (and (consp (car tail-cdr))
- (eq (car (car tail-cdr)) key))
- (setcdr tail (cdr tail-cdr))
- (setq tail tail-cdr))))
- alist)
+ (assoc-delete-all key alist #'eq))
(defun rassq-delete-all (value alist)
"Delete from ALIST all elements whose cdr is `eq' to VALUE.
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index efafdcf8325..d0b3127f71b 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -26,7 +26,6 @@
;;
;;; Code:
-
(require 'ert)
(eval-when-compile (require 'cl-lib))
@@ -307,5 +306,24 @@ cf. Bug#25477."
(should (eq (string-to-char (symbol-name (gensym))) ?g))
(should (eq (string-to-char (symbol-name (gensym "X"))) ?X)))
+(ert-deftest subr-tests--assq-delete-all ()
+ "Test `assq-delete-all' behavior."
+ (cl-flet ((new-list-fn
+ ()
+ (list (cons 'a 1) (cons 'b 2) (cons 'c 3) 'd (cons "foo" "bar"))))
+ (should (equal (cdr (new-list-fn)) (assq-delete-all 'a (new-list-fn))))
+ (should (equal (new-list-fn) (assq-delete-all 'd (new-list-fn))))
+ (should (equal (new-list-fn) (assq-delete-all "foo" (new-list-fn))))))
+
+(ert-deftest subr-tests--assoc-delete-all ()
+ "Test `assoc-delete-all' behavior."
+ (cl-flet ((new-list-fn
+ ()
+ (list (cons 'a 1) (cons 'b 2) (cons 'c 3) 'd (cons "foo" "bar"))))
+ (should (equal (cdr (new-list-fn)) (assoc-delete-all 'a (new-list-fn))))
+ (should (equal (new-list-fn) (assoc-delete-all 'd (new-list-fn))))
+ (should (equal (butlast (new-list-fn))
+ (assoc-delete-all "foo" (new-list-fn))))))
+
(provide 'subr-tests)
;;; subr-tests.el ends here
--
2.39.5