Re: [PATCH] assq-delete-all, rassq-delete-all: Avoid duplication of code

[Tino Calancha <tino.calancha@gmail.com>]

Clément Pit--Claudel <clement.pit@gmail.com> writes:

> On 2016-11-28 12:24, Eli Zaretskii wrote:
>>> From: Tino Calancha <tino.calancha@gmail.com>
>>> Date: Mon, 28 Nov 2016 18:52:36 +0900
>>> Cc: tino.calancha@gmail.com
>>>
>>> how about following patch?
>>> It prevent some duplication of code in subr.el, and it adds
>>> a new test.
>> 
>> What about the overhead of a function call?  These functions are
>> likely to be invoked in loops.
>> 
>> Should we make the common part a defsubst?
>
> Would defsubst be enough? I think you'd want a defmacro.  Otherwise,
> you'll still pay for all the funcalls to #'car and #'cdr, won't you?

Following patch makes `assq-delete-all-1' a macro:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
From 310fc091f1adbf7781e7069b313c03bb31e735a8 Mon Sep 17 00:00:00 2001
From: Tino Calancha <tino.calancha@gmail.com>
Date: Tue, 29 Nov 2016 17:15:30 +0900
Subject: [PATCH] assq-delete-all, rassq-delete-all: Avoid duplication of code

See discussion in:
https://lists.gnu.org/archive/html/emacs-devel/2016-11/msg00592.html
* lisp/subr.el (assq-delete-all-1): New macro.
(assq-delete-all, rassq-delete-all): Use it.
* test/lisp/subr-tests.el (subr-test-assq-delete-all): New test.
---
 lisp/subr.el            | 39 +++++++++++++++++++--------------------
 test/lisp/subr-tests.el | 12 ++++++++++++
 2 files changed, 31 insertions(+), 20 deletions(-)

diff --git a/lisp/subr.el b/lisp/subr.el
index 5da5bf8..69827be 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -570,35 +570,34 @@ member-ignore-case
     (setq list (cdr list)))
   list)
 
+(defmacro assq-delete-all-1 (elt alist rassq)
+  (let ((lst (make-symbol "alist"))
+        (tail (make-symbol "tail"))
+        (entry (make-symbol "entry")))
+    `(let ((,lst ,alist)
+           (,tail ,alist))
+       (while (and (consp (car ,lst))
+                   (eq ,(if rassq `(cdar ,lst) `(caar ,lst)) ,elt))
+         (setq ,lst (cdr ,lst)))
+       (while (cdr ,tail)
+         (let ((,entry (cdr ,tail)))
+           (if (and (consp (car ,entry))
+                    (eq ,(if rassq `(cdar ,entry) `(caar ,entry)) ,elt))
+               (setcdr ,tail (cdr ,entry))
+             (setq ,tail ,entry))))
+       ,lst)))
+
 (defun assq-delete-all (key alist)
   "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)
+  (assq-delete-all-1 key alist nil))
 
 (defun rassq-delete-all (value alist)
   "Delete from ALIST all elements whose cdr is `eq' to VALUE.
 Return the modified alist.
 Elements of ALIST that are not conses are ignored."
-  (while (and (consp (car alist))
-	      (eq (cdr (car alist)) value))
-    (setq alist (cdr alist)))
-  (let ((tail alist) tail-cdr)
-    (while (setq tail-cdr (cdr tail))
-      (if (and (consp (car tail-cdr))
-	       (eq (cdr (car tail-cdr)) value))
-	  (setcdr tail (cdr tail-cdr))
-	(setq tail tail-cdr))))
-  alist)
+  (assq-delete-all-1 value alist 'rassq))
 
 (defun alist-get (key alist &optional default remove)
   "Return the value associated with KEY in ALIST, using `assq'.
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index ce21290..018c13b 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -224,5 +224,17 @@
               (error-message-string (should-error (version-to-list "beta22_8alpha3")))
               "Invalid version syntax: `beta22_8alpha3' (must start with a number)"))))
 
+(ert-deftest subr-test-assq-delete-all ()
+  "Tests for `assq-delete-all' and `rassq-delete-all'."
+  (let ((alist '((foo . 1) (bar . 1) (baz . 1) (foo . 2))))
+    (should (equal '((bar . 1) (baz . 1))
+                   (assq-delete-all 'foo (copy-tree alist))))
+    (should (equal '((foo . 2)) (rassq-delete-all 1 (copy-tree alist))))
+    (should (equal alist (assq-delete-all 'qux (copy-tree alist))))
+    (should (equal alist (rassq-delete-all 9 (copy-tree alist))))
+    (should (equal alist
+                   (assq-delete-all (make-symbol "foo") (copy-tree alist))))
+    (should (equal alist (rassq-delete-all 1.0 (copy-tree alist))))))
+
 (provide 'subr-tests)
 ;;; subr-tests.el ends here
-- 
2.10.2

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
In GNU Emacs 26.0.50.1 (x86_64-pc-linux-gnu, GTK+ Version 3.22.4)
 of 2016-11-28
Repository revision: 2c8a7e50d24daf19ea7d86f1cfeaa98a41c56085