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

@@ -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

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.
 

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.

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