master b1ac23e 2/2: Allow add-to-ordered-list to use a test predicate

[Lars Ingebrigtsen]

branch: master
commit b1ac23ebef62d5a185727a4973462828dc6f65f0
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Allow add-to-ordered-list to use a test predicate
    
    * doc/lispref/lists.texi (List Variables): Update manual.
    
    * lisp/subr.el (add-to-ordered-list): Allow using a test
    predicate, and make slightly more efficient (bug#45539).
---
 doc/lispref/lists.texi  |  9 +++++----
 etc/NEWS                |  3 +++
 lisp/subr.el            | 43 ++++++++++++++++++++++++++-----------------
 test/lisp/subr-tests.el | 28 ++++++++++++++++++++++++++--
 4 files changed, 60 insertions(+), 23 deletions(-)

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index ae793d5..21ee386 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -807,13 +807,14 @@ foo                       ;; @r{@code{foo} was changed.}
   (setq @var{var} (cons @var{value} @var{var})))
 @end example
 
-@defun add-to-ordered-list symbol element &optional order
+@defun add-to-ordered-list symbol element &optional order test-function
 This function sets the variable @var{symbol} by inserting
 @var{element} into the old value, which must be a list, at the
 position specified by @var{order}.  If @var{element} is already a
-member of the list, its position in the list is adjusted according
-to @var{order}.  Membership is tested using @code{eq}.
-This function returns the resulting list, whether updated or not.
+member of the list, its position in the list is adjusted according to
+@var{order}.  Membership is tested using @var{test-function},
+defaulting to @code{eq} if @var{test-function} isn't present.  This
+function returns the resulting list, whether updated or not.
 
 The @var{order} is typically a number (integer or float), and the
 elements of the list are sorted in non-decreasing numerical order.
diff --git a/etc/NEWS b/etc/NEWS
index 1b49b01..865dbdf 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1483,6 +1483,9 @@ that makes it a valid button.
 ** Miscellaneous
 
 +++
+*** 'add-to-ordered-list' can now take a test predicate.
+
++++
 *** New predicate functions 'length<', 'length>' and 'length='.
 Using these functions may be more efficient than using 'length' (if
 the length of a (long) list is being computed just to compare this
diff --git a/lisp/subr.el b/lisp/subr.el
index ed0d697..77b142c 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1971,13 +1971,13 @@ can do the job."
           (cons element (symbol-value list-var))))))
 
 
-(defun add-to-ordered-list (list-var element &optional order)
+(defun add-to-ordered-list (list-var element &optional order test-function)
   "Add ELEMENT to the value of LIST-VAR if it isn't there yet.
-The test for presence of ELEMENT is done with `eq'.
+TEST-FUNCTION is used to test for the presence of ELEMENT, and
+defaults to `eq'.
 
-The resulting list is reordered so that the elements are in the
-order given by each element's numeric list order.  Elements
-without a numeric list order are placed at the end of the list.
+The value of LIST-VAR is kept ordered based on the ORDER
+parameter.
 
 If the third optional argument ORDER is a number (integer or
 float), set the element's list order to the given value.  If
@@ -1990,21 +1990,30 @@ The list order for each element is stored in LIST-VAR's
 LIST-VAR cannot refer to a lexical variable.
 
 The return value is the new value of LIST-VAR."
-  (let ((ordering (get list-var 'list-order)))
+  (let ((ordering (get list-var 'list-order))
+        missing)
+    ;; Make a hash table for storing the ordering.
     (unless ordering
       (put list-var 'list-order
-           (setq ordering (make-hash-table :weakness 'key :test 'eq))))
-    (when order
-      (puthash element (and (numberp order) order) ordering))
-    (unless (memq element (symbol-value list-var))
+           (setq ordering (make-hash-table :weakness 'key
+                                           :test (or test-function #'eq)))))
+    (when (and test-function
+               (not (eq test-function (hash-table-test ordering))))
+      (error "Conflicting test functions given"))
+    ;; Add new values.
+    (when (setq missing (eq (gethash element ordering 'missing) 'missing))
       (set list-var (cons element (symbol-value list-var))))
-    (set list-var (sort (symbol-value list-var)
-                       (lambda (a b)
-                         (let ((oa (gethash a ordering))
-                               (ob (gethash b ordering)))
-                           (if (and oa ob)
-                               (< oa ob)
-                             oa)))))))
+    ;; Set/change the order.
+    (when (or order missing)
+      (setf (gethash element ordering) (and (numberp order) order)))
+    (set list-var
+         (sort (symbol-value list-var)
+              (lambda (a b)
+                (let ((oa (gethash a ordering))
+                      (ob (gethash b ordering)))
+                  (if (and oa ob)
+                      (< oa ob)
+                    oa)))))))
 
 (defun add-to-history (history-var newelt &optional maxelt keep-all)
   "Add NEWELT to the history list stored in the variable HISTORY-VAR.
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 3154135..5be3b89 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -600,7 +600,7 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350.";
 
 (defvar subr--ordered nil)
 
-(ert-deftest subr--add-to-ordered-list ()
+(ert-deftest subr--add-to-ordered-list-eq ()
   (setq subr--ordered nil)
   (add-to-ordered-list 'subr--ordered 'b 2)
   (should (equal subr--ordered '(b)))
@@ -611,7 +611,31 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350.";
   (add-to-ordered-list 'subr--ordered 'e)
   (should (equal subr--ordered '(a b c e)))
   (add-to-ordered-list 'subr--ordered 'd 4)
-  (should (equal subr--ordered '(a b c d e))))
+  (should (equal subr--ordered '(a b c d e)))
+  (add-to-ordered-list 'subr--ordered 'e)
+  (should (equal subr--ordered '(a b c d e)))
+  (add-to-ordered-list 'subr--ordered 'b 5)
+  (should (equal subr--ordered '(a c d b e))))
+
+(defvar subr--ordered-s nil)
+
+(ert-deftest subr--add-to-ordered-list-equal ()
+  (setq subr--ordered-s nil)
+  (add-to-ordered-list 'subr--ordered-s "b" 2 #'equal)
+  (should (equal subr--ordered-s '("b")))
+  (add-to-ordered-list 'subr--ordered-s "c" 3)
+  (should (equal subr--ordered-s '("b" "c")))
+  (add-to-ordered-list 'subr--ordered-s "a" 1)
+  (should (equal subr--ordered-s '("a" "b" "c")))
+  (add-to-ordered-list 'subr--ordered-s "e")
+  (should (equal subr--ordered-s '("a" "b" "c" "e")))
+  (add-to-ordered-list 'subr--ordered-s "d" 4)
+  (should (equal subr--ordered-s '("a" "b" "c" "d" "e")))
+  (add-to-ordered-list 'subr--ordered-s "e")
+  (should (equal subr--ordered-s '("a" "b" "c" "d" "e")))
+  (add-to-ordered-list 'subr--ordered-s "b" 5)
+  (should (equal subr--ordered-s '("a" "c" "d" "b" "e")))
+  (should-error (add-to-ordered-list 'subr--ordered-s "b" 5 #'eql)))
 
 
 ;;; Apropos.