From bcea05dbe58df854d68eaaddaaa8ab0540f6a37f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jo=C3=A3o=20T=C3=A1vora?= Date: Sun, 12 Nov 2023 00:52:18 +0000 Subject: [PATCH] Cl-lib: optimize cl-set-difference and cl-nset-difference Also correct a bytecomp.el warning about cl-nset-difference being called with a constant second argument. It's not a problem, as it isn't destroyed. * lisp/emacs-lisp/bytecomp.el (byte-compile-form): Tweak. * lisp/emacs-lisp/cl-seq.el (cl--with-member-test): New helper macro. (cl-set-difference): Use it. Reword docstring. (cl-nset-difference): Use it. Reword docstring. --- lisp/emacs-lisp/bytecomp.el | 2 +- lisp/emacs-lisp/cl-seq.el | 124 +++++++++++++++++++++++---- test/lisp/emacs-lisp/cl-lib-tests.el | 32 +++++++ 3 files changed, 138 insertions(+), 20 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index cc68db73c9f..e1a11ff9ba3 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3601,7 +3601,7 @@ lambda-expression." (cl-nsubst 3) (cl-nsubst-if 3) (cl-nsubst-if-not 3) (cl-nsubstitute 3) (cl-nsubstitute-if 3) (cl-nsubstitute-if-not 3) (cl-nsublis 2) - (cl-nunion 1 2) (cl-nintersection 1 2) (cl-nset-difference 1 2) + (cl-nunion 1 2) (cl-nintersection 1 2) (cl-nset-difference 1) (cl-nset-exclusive-or 1 2) (cl-nreconc 1) (cl-sort 1) (cl-stable-sort 1) (cl-merge 2 3) diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 9df67bc6260..1b9e785e151 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -983,36 +983,122 @@ whenever possible. \n(fn LIST1 LIST2 [KEYWORD VALUE]...)" (and cl-list1 cl-list2 (apply 'cl-intersection cl-list1 cl-list2 cl-keys))) +(defmacro cl--with-member-test (mtest keyword-plist &rest body) + (declare (indent 2) (debug (sexp sexp &rest form))) + (let ((plist (gensym "plist-")) + (key (gensym "key-")) + (test (gensym "test-")) + (test-not (gensym "test-not-"))) + `(let* ((,plist ,keyword-plist) + (,key (plist-get ,plist :key)) + (,test (plist-get ,plist :test)) + (,test-not (plist-get ,plist :test-not)) + (,mtest + (cond (,test-not + (cond (,key + (lambda (e l) + (setq e (funcall ,key e)) + (catch 'done + (while l + (unless (funcall ,test-not e (funcall ,key (car l))) + (throw 'done t)) + (setq l (cdr l)))))) + (t + (lambda (e l) + (catch 'done + (while l + (unless (funcall ,test-not e (car l)) + (throw 'done t)) + (setq l (cdr l)))))))) + (,test + (cond (,key + (lambda (e l) + (setq e (funcall ,key e)) + (catch 'done + (while l + (when (funcall ,test e (funcall ,key (car l))) + (throw 'done t)) + (setq l (cdr l)))))) + ((eq ,test #'eq) #'memq) + ((eq ,test #'eql) #'memql) + ((eq ,test #'equal) #'member) + (t + (lambda (e l) + (catch 'done + (while l + (when (funcall ,test e (car l)) + (throw 'done t)) + (setq l (cdr l)))))))) + (,key + (lambda (e l) + (setq e (funcall ,key e)) + (catch 'done + (while l + (when (eql e (funcall ,key (car l))) + (throw 'done t)) + (setq l (cdr l)))))) + (t #'memql)))) + ,@body))) + ;;;###autoload -(defun cl-set-difference (cl-list1 cl-list2 &rest cl-keys) +(defun cl-set-difference (list1 list2 &rest keys) "Combine LIST1 and LIST2 using a set-difference operation. -The resulting list contains all items that appear in LIST1 but not LIST2. + +The resulting list contains all items that appear in LIST1 but +not LIST2. An element is said to appear in a list if the element +and at least one member of that list satisfy the comparison test +to. By default, elements are compared with `eql'. + +If KEY is supplied, is should be a unary function. In that case +elements are not compared directly. Intead, the result of +calling the KEY on each pair of elements is used. + +If TEST is supplied, it it used to compare elements. If TEST-NOT +is supplied, the comparison test is satisfied if TEST-NOT returns +false. + This is a non-destructive function; it makes a copy of the data if necessary to avoid corrupting the original LIST1 and LIST2. -\nKeywords supported: :test :test-not :key -\n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (if (or (null cl-list1) (null cl-list2)) cl-list1 - (cl--parsing-keywords (:key) (:test :test-not) + +\n(fn LIST1 LIST2 &key TEST TEST-NOT KEY)" + (if (or (null list1) (null list2)) list1 + (cl--with-member-test mtest keys (let ((cl-res nil)) - (while cl-list1 - (or (if (or cl-keys (numberp (car cl-list1))) - (apply 'cl-member (cl--check-key (car cl-list1)) - cl-list2 cl-keys) - (memq (car cl-list1) cl-list2)) - (push (car cl-list1) cl-res)) - (pop cl-list1)) + (while list1 + (or (funcall mtest (car list1) list2) + (push (car list1) cl-res)) + (pop list1)) (nreverse cl-res))))) ;;;###autoload -(defun cl-nset-difference (cl-list1 cl-list2 &rest cl-keys) +(defun cl-nset-difference (list1 list2 &rest keys) "Combine LIST1 and LIST2 using a set-difference operation. -The resulting list contains all items that appear in LIST1 but not LIST2. + +The resulting list contains all items that appear in LIST1 but +not LIST2. An element is said to appear in a list if the element +and at least one member of that list satisfy the comparison test +to. By default, elements are compared with `eql'. + +If KEY is supplied, is should be a unary function. In that case +elements are not compared directly. Intead, the result of +calling the KEY on each pair of elements is used. + +If TEST is supplied, it it used to compare elements. If TEST-NOT +is supplied, the comparison test is satisfied if TEST-NOT returns +false. + This is a destructive function; it reuses the storage of LIST1 and LIST2 whenever possible. -\nKeywords supported: :test :test-not :key -\n(fn LIST1 LIST2 [KEYWORD VALUE]...)" - (if (or (null cl-list1) (null cl-list2)) cl-list1 - (apply 'cl-set-difference cl-list1 cl-list2 cl-keys))) + +\n(fn LIST1 LIST2 &key TEST TEST-NOT KEY)" + (if (or (null list1) (null list2)) list1 + (cl--with-member-test mtest keys + (let ((res nil)) + (while (consp list1) + (if (funcall mtest (car list1) list2) + (setf list1 (cdr list1)) + (cl-shiftf list1 (cdr list1) res list1))) + res)))) ;;;###autoload (defun cl-set-exclusive-or (cl-list1 cl-list2 &rest cl-keys) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 0995e71db4e..edb851ad31d 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -558,5 +558,37 @@ (should (equal (mapcar (cl-constantly 3) '(a b c d)) '(3 3 3 3)))) +(ert-deftest cl-set-difference () + ;; our set-difference preserves order, though it is not required to + ;; by cl standards. Nevertheless better keep that invariant + (should (equal (cl-set-difference '(1 2 3 4) '(3 4 5 6)) + '(1 2)))) + +(ert-deftest cl-nset-difference () + ;; our nset-difference doesn't + (let* ((l1 (list 1 2 3 4)) (l2 '(3 4 5 6)) + (diff (cl-nset-difference l1 l2))) + (should (memq 1 diff)) + (should (memq 2 diff)) + (should (= (length diff) 2)) + (should (equal l2 '(3 4 5 6)))) + (let* ((l1 (list "1" "2" "3" "4")) (l2 '("3" "4" "5" "6")) + (diff (cl-nset-difference l1 l2 :test #'equal))) + (should (member "1" diff)) + (should (member "2" diff)) + (should (= (length diff) 2)) + (should (equal l2 '("3" "4" "5" "6")))) + (let* ((l1 (list '(a . 1) '(b . 2) '(c . 3) '(d . 4))) + (l2 (list '(c . 3) '(d . 4) '(e . 5) '(f . 6))) + (diff (cl-nset-difference l1 l2 :key #'car))) + (should (member '(a . 1) diff)) + (should (member '(b . 2) diff)) + (should (= (length diff) 2))) + (let* ((l1 (list '("a" . 1) '("b" . 2) '("c" . 3) '("d" . 4))) + (l2 (list '("c" . 3) '("d" . 4) '("e" . 5) '("f" . 6))) + (diff (cl-nset-difference l1 l2 :key #'car :test #'string=))) + (should (member '("a" . 1) diff)) + (should (member '("b" . 2) diff)) + (should (= (length diff) 2)))) ;;; cl-lib-tests.el ends here