From b1ac23ebef62d5a185727a4973462828dc6f65f0 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Thu, 31 Dec 2020 05:28:47 +0100 Subject: [PATCH] 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 ae793d5e15e..21ee386335e 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 1b49b015608..865dbdf516c 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1482,6 +1482,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 diff --git a/lisp/subr.el b/lisp/subr.el index ed0d6978d03..77b142c4152 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 3154135ce17..5be3b8915a2 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. -- 2.39.5