From c1ef7adeb649aa99a10c4bd3b6ce988b309da3cc Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Sun, 14 Feb 2021 13:56:53 +0100 Subject: Add 'read-extended-command-predicate' * doc/emacs/m-x.texi (M-x): Document it. * doc/lispref/commands.texi (Interactive Call): Document it further. * lisp/simple.el (read-extended-command-predicate): New user option. (read-extended-command-predicate): Use it. (completion-in-mode-p): New function (the default predicate). --- lisp/emacs-lisp/seq.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp/emacs-lisp/seq.el') diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 31c15fea90d..55ce6d9426d 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -455,6 +455,7 @@ negative integer or 0, nil is returned." (setq sequence (seq-drop sequence n))) (nreverse result)))) +;;;###autoload (cl-defgeneric seq-intersection (sequence1 sequence2 &optional testfn) "Return a list of the elements that appear in both SEQUENCE1 and SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." -- cgit v1.2.3 From 6172454ff36a23b903352ef099f15de7d013a3c9 Mon Sep 17 00:00:00 2001 From: Juri Linkov Date: Tue, 23 Feb 2021 21:05:30 +0200 Subject: Small fixes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * lisp/emacs-lisp/seq.el (seq-contains): Move the ‘declare’ form after the docstring. * lisp/misc.el (copy-from-above-command): Fix whitespace regexp. --- lisp/emacs-lisp/seq.el | 2 +- lisp/misc.el | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp/emacs-lisp/seq.el') diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 55ce6d9426d..adfce950176 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -393,9 +393,9 @@ found or not." count)) (cl-defgeneric seq-contains (sequence elt &optional testfn) - (declare (obsolete seq-contains-p "27.1")) "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." + (declare (obsolete seq-contains-p "27.1")) (seq-some (lambda (e) (when (funcall (or testfn #'equal) elt e) e)) diff --git a/lisp/misc.el b/lisp/misc.el index 09f6011f98d..39ec9497d7f 100644 --- a/lisp/misc.el +++ b/lisp/misc.el @@ -41,7 +41,7 @@ The characters copied are inserted in the buffer before point." (save-excursion (beginning-of-line) (backward-char 1) - (skip-chars-backward "\ \t\n") + (skip-chars-backward " \t\n") (move-to-column cc) ;; Default is enough to copy the whole rest of the line. (setq n (if arg (prefix-numeric-value arg) (point-max))) -- cgit v1.2.3 From d925121b1e1cdf953705a5da43f8092f2a6e1d8c Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Wed, 24 Feb 2021 00:53:05 +0000 Subject: Various map.el improvements * lisp/emacs-lisp/seq.el (seq-do-indexed): Return nil as per doc. * lisp/emacs-lisp/map.el: Require Emacs >= 26 due to dependence on 5-arg alist-get. Bump package to version 3.0. Fix other headers. (Bug#46754) (map--plist-p): Detect list starting with nil as plist, not alist. (map-elt, map-filter, map-apply, map--make-pcase-bindings) (map--make-pcase-patterns): Simplify. (map-let, map-put, map-nested-elt, mapp): Update docstring for plist support. (map-delete): Fix OBOE on arrays. Split into cl-defmethods. (map-values, map-values-apply): Specialize for arrays. (map-pairs, map-keys-apply, map-put!): Improve docstring. (map-length): Clarify docstring w.r.t. duplicate keys. Split into cl-defmethods. Optimize default implementation. (map-copy): Use copy-alist on alists. Split into cl-defmethods. (map-contains-key): Add plist support. Clarify docstring w.r.t. optional argument. Simplify default implementation. (map-some, map-every-p, map-merge, map-merge-with, map--into-hash): Don't use map-apply for side effects. (map-into): Preserve plist ordering. Improve docstrings. (map-insert): Add hash-table and array support. (map-inplace): Remove unused error symbol. (map-do): Return nil as per doc. * etc/NEWS: Announce new user-visible behavior. * test/lisp/emacs-lisp/map-tests.el: Prefer should-not over (should (not ...)) in general. (with-maps-do): Fix docstring. (with-empty-maps-do): New macro. (test-map-elt-default, test-mapp, test-map-keys, test-map-values) (test-map-pairs, test-map-length, test-map-copy, test-map-apply) (test-map-do, test-map-keys-apply, test-map-values-apply) (test-map-filter, test-map-remove, test-map-empty-p) (test-map-contains-key, test-map-some, test-map-every-p): Use it. (test-map-plist-p, test-map-put!-new-keys, test-map-insert-empty) (test-map-insert, test-map-delete-empty, test-map-copy-alist) (test-map-contains-key-testfn, test-map-into-hash-test) (test-map-into-empty, test-map-merge, test-map-merge-empty): New tests. (test-map-elt): Test array key that is within bounds but not fixnum. (test-map-put!): Use map--plist-p. Remove redundant tests. (test-map-put-alist-new-key): Don't modify list literal. (test-map-put-testfn-alist, test-map-put-return-value): Silence obsoletion warnings. (test-map-delete): Check for OBOE on arrays. (test-map-delete-return-value): Remove test made redundant by test-map-delete. (test-map-nested-elt, test-map-into): Test plists too. --- etc/NEWS | 7 + lisp/emacs-lisp/map.el | 320 +++++++++++++------------ lisp/emacs-lisp/seq.el | 7 +- test/lisp/emacs-lisp/map-tests.el | 474 +++++++++++++++++++++++--------------- 4 files changed, 471 insertions(+), 337 deletions(-) (limited to 'lisp/emacs-lisp/seq.el') diff --git a/etc/NEWS b/etc/NEWS index 6b4456e3de9..5487448eaeb 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1160,6 +1160,13 @@ effect. A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym', equivalent to '(map (:sym sym))'. +--- +*** The function 'map-copy' now uses 'copy-alist' on alists. +This is a slightly deeper copy than the previous 'copy-sequence'. + +--- +*** The function 'map-contains-key' now supports plists. + ** Package +++ diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 46a1bd21a3d..c0cbc7b5a18 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -3,12 +3,10 @@ ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. ;; Author: Nicolas Petton -;; Keywords: convenience, map, hash-table, alist, array -;; Version: 2.1 -;; Package-Requires: ((emacs "25")) -;; Package: map - ;; Maintainer: emacs-devel@gnu.org +;; Keywords: extensions, lisp +;; Version: 3.0 +;; Package-Requires: ((emacs "26")) ;; This file is part of GNU Emacs. @@ -27,8 +25,9 @@ ;;; Commentary: -;; map.el provides map-manipulation functions that work on alists, -;; hash-table and arrays. All functions are prefixed with "map-". +;; map.el provides generic map-manipulation functions that work on +;; alists, plists, hash-tables, and arrays. All functions are +;; prefixed with "map-". ;; ;; Functions taking a predicate or iterating over a map using a ;; function take the function as their first argument. All other @@ -54,7 +53,7 @@ ARGS is a list of elements to be matched in the map. Each element of ARGS can be of the form (KEY PAT), in which case KEY is evaluated and searched for in the map. The match fails if for any KEY found in the map, the corresponding PAT doesn't match the value -associated to the KEY. +associated with the KEY. Each element can also be a SYMBOL, which is an abbreviation of a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL @@ -75,7 +74,7 @@ bound to the looked up value in MAP. KEYS can also be a list of (KEY VARNAME) pairs, in which case KEY is an unquoted form. -MAP can be a list, hash-table or array." +MAP can be an alist, plist, hash-table, or array." (declare (indent 2) (debug ((&rest &or symbolp ([form symbolp])) form body))) `(pcase-let ((,(map--make-pcase-patterns keys) ,map)) @@ -101,7 +100,7 @@ Returns the result of evaluating the form associated with MAP-VAR's type." (define-error 'map-not-inplace "Cannot modify map in-place") (defsubst map--plist-p (list) - (and (consp list) (not (listp (car list))))) + (and (consp list) (atom (car list)))) (cl-defgeneric map-elt (map key &optional default testfn) "Lookup KEY in MAP and return its associated value. @@ -109,7 +108,8 @@ If KEY is not found, return DEFAULT which defaults to nil. TESTFN is deprecated. Its default depends on the MAP argument. -In the base definition, MAP can be an alist, hash-table, or array." +In the base definition, MAP can be an alist, plist, hash-table, +or array." (declare (gv-expander (lambda (do) @@ -127,26 +127,25 @@ In the base definition, MAP can be an alist, hash-table, or array." `(map-insert ,mgetter ,key ,v)))))))))) ;; `testfn' is deprecated. (advertised-calling-convention (map key &optional default) "27.1")) + ;; Can't use `cl-defmethod' with `advertised-calling-convention'. (map--dispatch map :list (if (map--plist-p map) - (let ((res (plist-get map key))) - (if (and default (null res) (not (plist-member map key))) - default - res)) + (let ((res (plist-member map key))) + (if res (cadr res) default)) (alist-get key map default nil testfn)) :hash-table (gethash key map default) - :array (if (and (>= key 0) (< key (seq-length map))) - (seq-elt map key) + :array (if (map-contains-key map key) + (aref map key) default))) (defmacro map-put (map key value &optional testfn) "Associate KEY with VALUE in MAP and return VALUE. If KEY is already present in MAP, replace the associated value with VALUE. -When MAP is a list, test equality with TESTFN if non-nil, +When MAP is an alist, test equality with TESTFN if non-nil, otherwise use `eql'. -MAP can be a list, hash-table or array." +MAP can be an alist, plist, hash-table, or array." (declare (obsolete "use map-put! or (setf (map-elt ...) ...) instead" "27.1")) `(setf (map-elt ,map ,key nil ,testfn) ,value)) @@ -168,23 +167,30 @@ MAP can be a list, hash-table or array." (cl-defgeneric map-delete (map key) "Delete KEY in-place from MAP and return MAP. -No error is signaled if KEY is not a key of MAP. -If MAP is an array, store nil at the index KEY." - (map--dispatch map - ;; FIXME: Signal map-not-inplace i.s.o returning a different list? - :list (if (map--plist-p map) - (setq map (map--plist-delete map key)) - (setf (alist-get key map nil t) nil)) - :hash-table (remhash key map) - :array (and (>= key 0) - (<= key (seq-length map)) - (aset map key nil))) +Keys not present in MAP are ignored.") + +(cl-defmethod map-delete ((map list) key) + ;; FIXME: Signal map-not-inplace i.s.o returning a different list? + (if (map--plist-p map) + (map--plist-delete map key) + (setf (alist-get key map nil t) nil) + map)) + +(cl-defmethod map-delete ((map hash-table) key) + (remhash key map) + map) + +(cl-defmethod map-delete ((map array) key) + "Store nil at index KEY." + (when (map-contains-key map key) + (aset map key nil)) map) (defun map-nested-elt (map keys &optional default) "Traverse MAP using KEYS and return the looked up value or DEFAULT if nil. -Map can be a nested map composed of alists, hash-tables and arrays." +MAP can be a nested map composed of alists, plists, hash-tables, +and arrays." (or (seq-reduce (lambda (acc key) (when (mapp acc) (map-elt acc key))) @@ -202,30 +208,49 @@ The default implementation delegates to `map-apply'." The default implementation delegates to `map-apply'." (map-apply (lambda (_ value) value) map)) +(cl-defmethod map-values ((map array)) + "Convert MAP into a list." + (append map ())) + (cl-defgeneric map-pairs (map) - "Return the elements of MAP as key/value association lists. + "Return the key/value pairs in MAP as an alist. The default implementation delegates to `map-apply'." (map-apply #'cons map)) (cl-defgeneric map-length (map) ;; FIXME: Should we rename this to `map-size'? - "Return the number of elements in the map. -The default implementation counts `map-keys'." - (cond - ((hash-table-p map) (hash-table-count map)) - ((listp map) - ;; FIXME: What about repeated/shadowed keys? - (if (map--plist-p map) (/ (length map) 2) (length map))) - ((arrayp map) (length map)) - (t (length (map-keys map))))) + "Return the number of key/value pairs in MAP. +Note that this does not always reflect the number of unique keys. +The default implementation delegates to `map-do'." + (let ((size 0)) + (map-do (lambda (_k _v) (setq size (1+ size))) map) + size)) + +(cl-defmethod map-length ((map hash-table)) + (hash-table-count map)) + +(cl-defmethod map-length ((map list)) + (if (map--plist-p map) + (/ (length map) 2) + (length map))) + +(cl-defmethod map-length ((map array)) + (length map)) (cl-defgeneric map-copy (map) - "Return a copy of MAP." - ;; FIXME: Clarify how deep is the copy! - (map--dispatch map - :list (seq-copy map) ;FIXME: Probably not deep enough for alists! - :hash-table (copy-hash-table map) - :array (seq-copy map))) + "Return a copy of MAP.") + +(cl-defmethod map-copy ((map list)) + "Use `copy-alist' on alists and `copy-sequence' on plists." + (if (map--plist-p map) + (copy-sequence map) + (copy-alist map))) + +(cl-defmethod map-copy ((map hash-table)) + (copy-hash-table map)) + +(cl-defmethod map-copy ((map array)) + (copy-sequence map)) (cl-defgeneric map-apply (function map) "Apply FUNCTION to each element of MAP and return the result as a list. @@ -243,26 +268,28 @@ FUNCTION is called with two arguments, the key and the value.") (cl-defmethod map-do (function (map hash-table)) (maphash function map)) (cl-defgeneric map-keys-apply (function map) - "Return the result of applying FUNCTION to each key of MAP. + "Return the result of applying FUNCTION to each key in MAP. The default implementation delegates to `map-apply'." (map-apply (lambda (key _) (funcall function key)) map)) (cl-defgeneric map-values-apply (function map) - "Return the result of applying FUNCTION to each value of MAP. + "Return the result of applying FUNCTION to each value in MAP. The default implementation delegates to `map-apply'." (map-apply (lambda (_ val) (funcall function val)) map)) +(cl-defmethod map-values-apply (function (map array)) + (mapcar function map)) + (cl-defgeneric map-filter (pred map) "Return an alist of key/val pairs for which (PRED key val) is non-nil in MAP. The default implementation delegates to `map-apply'." (delq nil (map-apply (lambda (key val) - (if (funcall pred key val) - (cons key val) - nil)) + (and (funcall pred key val) + (cons key val))) map))) (cl-defgeneric map-remove (pred map) @@ -272,7 +299,7 @@ The default implementation delegates to `map-filter'." map)) (cl-defgeneric mapp (map) - "Return non-nil if MAP is a map (alist, hash-table, array, ...)." + "Return non-nil if MAP is a map (alist/plist, hash-table, array, ...)." (or (listp map) (hash-table-p map) (arrayp map))) @@ -292,56 +319,58 @@ The default implementation delegates to `map-length'." ;; test function! "Return non-nil if and only if MAP contains KEY. TESTFN is deprecated. Its default depends on MAP. -The default implementation delegates to `map-do'." +The default implementation delegates to `map-some'." (unless testfn (setq testfn #'equal)) - (catch 'map--catch - (map-do (lambda (k _v) - (if (funcall testfn key k) (throw 'map--catch t))) - map) - nil)) + (map-some (lambda (k _v) (funcall testfn key k)) map)) (cl-defmethod map-contains-key ((map list) key &optional testfn) - (let ((v '(nil))) - (not (eq v (alist-get key map v nil (or testfn #'equal)))))) + "Return non-nil if MAP contains KEY. +If MAP is an alist, TESTFN defaults to `equal'. +If MAP is a plist, `plist-member' is used instead." + (if (map--plist-p map) + (plist-member map key) + (let ((v '(nil))) + (not (eq v (alist-get key map v nil (or testfn #'equal))))))) (cl-defmethod map-contains-key ((map array) key &optional _testfn) - (and (integerp key) - (>= key 0) - (< key (length map)))) + "Return non-nil if KEY is an index of MAP, ignoring TESTFN." + (and (natnump key) (< key (length map)))) (cl-defmethod map-contains-key ((map hash-table) key &optional _testfn) + "Return non-nil if MAP contains KEY, ignoring TESTFN." (let ((v '(nil))) (not (eq v (gethash key map v))))) (cl-defgeneric map-some (pred map) "Return the first non-nil (PRED key val) in MAP. -The default implementation delegates to `map-apply'." +Return nil if no such element is found. +The default implementation delegates to `map-do'." ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, ;; since as defined, I can't think of a map-type where we could provide an ;; algorithmically more efficient algorithm than the default. (catch 'map--break - (map-apply (lambda (key value) - (let ((result (funcall pred key value))) - (when result - (throw 'map--break result)))) - map) + (map-do (lambda (key value) + (let ((result (funcall pred key value))) + (when result + (throw 'map--break result)))) + map) nil)) (cl-defgeneric map-every-p (pred map) "Return non-nil if (PRED key val) is non-nil for all elements of MAP. -The default implementation delegates to `map-apply'." +The default implementation delegates to `map-do'." ;; FIXME: Not sure if there's much benefit to defining it as defgeneric, ;; since as defined, I can't think of a map-type where we could provide an ;; algorithmically more efficient algorithm than the default. (catch 'map--break - (map-apply (lambda (key value) + (map-do (lambda (key value) (or (funcall pred key value) (throw 'map--break nil))) map) t)) (defun map-merge (type &rest maps) - "Merge into a map of type TYPE all the key/value pairs in MAPS. + "Merge into a map of TYPE all the key/value pairs in MAPS. See `map-into' for all supported values of TYPE." (let ((result (map-into (pop maps) type))) (while maps @@ -349,48 +378,57 @@ See `map-into' for all supported values of TYPE." ;; For small tables, this is fine, but for large tables, we ;; should probably use a hash-table internally which we convert ;; to an alist in the end. - (map-apply (lambda (key value) - (setf (map-elt result key) value)) - (pop maps))) + (map-do (lambda (key value) + (setf (map-elt result key) value)) + (pop maps))) result)) (defun map-merge-with (type function &rest maps) - "Merge into a map of type TYPE all the key/value pairs in MAPS. -When two maps contain the same key (`eql'), call FUNCTION on the two + "Merge into a map of TYPE all the key/value pairs in MAPS. +When two maps contain the same (`eql') key, call FUNCTION on the two values and use the value returned by it. -MAP can be a list, hash-table or array. +Each of MAPS can be an alist, plist, hash-table, or array. See `map-into' for all supported values of TYPE." (let ((result (map-into (pop maps) type)) - (not-found (cons nil nil))) + (not-found (list nil))) (while maps - (map-apply (lambda (key value) - (cl-callf (lambda (old) - (if (eql old not-found) - value - (funcall function old value))) - (map-elt result key not-found))) - (pop maps))) + (map-do (lambda (key value) + (cl-callf (lambda (old) + (if (eql old not-found) + value + (funcall function old value))) + (map-elt result key not-found))) + (pop maps))) result)) (cl-defgeneric map-into (map type) - "Convert the map MAP into a map of type TYPE.") + "Convert MAP into a map of TYPE.") + ;; FIXME: I wish there was a way to avoid this η-redex! -(cl-defmethod map-into (map (_type (eql list))) (map-pairs map)) -(cl-defmethod map-into (map (_type (eql alist))) (map-pairs map)) +(cl-defmethod map-into (map (_type (eql list))) + "Convert MAP into an alist." + (map-pairs map)) + +(cl-defmethod map-into (map (_type (eql alist))) + "Convert MAP into an alist." + (map-pairs map)) + (cl-defmethod map-into (map (_type (eql plist))) - (let ((plist '())) - (map-do (lambda (k v) (setq plist `(,k ,v ,@plist))) map) - plist)) + "Convert MAP into a plist." + (let (plist) + (map-do (lambda (k v) (setq plist `(,v ,k ,@plist))) map) + (nreverse plist))) (cl-defgeneric map-put! (map key value &optional testfn) "Associate KEY with VALUE in MAP. If KEY is already present in MAP, replace the associated value with VALUE. This operates by modifying MAP in place. -If it cannot do that, it signals the `map-not-inplace' error. -If you want to insert an element without modifying MAP, use `map-insert'." +If it cannot do that, it signals a `map-not-inplace' error. +To insert an element without modifying MAP, use `map-insert'." ;; `testfn' only exists for backward compatibility with `map-put'! (declare (advertised-calling-convention (map key value) "27.1")) + ;; Can't use `cl-defmethod' with `advertised-calling-convention'. (map--dispatch map :list (if (map--plist-p map) @@ -404,18 +442,20 @@ If you want to insert an element without modifying MAP, use `map-insert'." ;; and let `map-insert' grow the array? :array (aset map key value))) -(define-error 'map-inplace "Can only modify map in place") - (cl-defgeneric map-insert (map key value) "Return a new map like MAP except that it associates KEY with VALUE. This does not modify MAP. -If you want to insert an element in place, use `map-put!'." - (if (listp map) - (if (map--plist-p map) - `(,key ,value ,@map) - (cons (cons key value) map)) - ;; FIXME: Should we signal an error or use copy+put! ? - (signal 'map-inplace (list map)))) +If you want to insert an element in place, use `map-put!'. +The default implementation defaults to `map-copy' and `map-put!'." + (let ((copy (map-copy map))) + (map-put! copy key value) + copy)) + +(cl-defmethod map-insert ((map list) key value) + "Cons KEY and VALUE to the front of MAP." + (if (map--plist-p map) + (cons key (cons value map)) + (cons (cons key value) map))) ;; There shouldn't be old source code referring to `map--put', yet we do ;; need to keep it for backward compatibility with .elc files where the @@ -425,11 +465,9 @@ If you want to insert an element in place, use `map-put!'." (cl-defmethod map-apply (function (map list)) (if (map--plist-p map) (cl-call-next-method) - (seq-map (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - map))) + (mapcar (lambda (pair) + (funcall function (car pair) (cdr pair))) + map))) (cl-defmethod map-apply (function (map hash-table)) (let (result) @@ -439,46 +477,40 @@ If you want to insert an element in place, use `map-put!'." (nreverse result))) (cl-defmethod map-apply (function (map array)) - (let ((index 0)) - (seq-map (lambda (elt) - (prog1 - (funcall function index elt) - (setq index (1+ index)))) - map))) + (seq-map-indexed (lambda (elt index) + (funcall function index elt)) + map)) (cl-defmethod map-do (function (map list)) - "Private function used to iterate over ALIST using FUNCTION." (if (map--plist-p map) (while map (funcall function (pop map) (pop map))) - (seq-do (lambda (pair) - (funcall function - (car pair) - (cdr pair))) - map))) + (mapc (lambda (pair) + (funcall function (car pair) (cdr pair))) + map) + nil)) -(cl-defmethod map-do (function (array array)) - "Private function used to iterate over ARRAY using FUNCTION." +(cl-defmethod map-do (function (map array)) (seq-do-indexed (lambda (elt index) - (funcall function index elt)) - array)) + (funcall function index elt)) + map)) (defun map--into-hash (map keyword-args) "Convert MAP into a hash-table. KEYWORD-ARGS are forwarded to `make-hash-table'." (let ((ht (apply #'make-hash-table keyword-args))) - (map-apply (lambda (key value) - (setf (gethash key ht) value)) - map) + (map-do (lambda (key value) + (puthash key value ht)) + map) ht)) (cl-defmethod map-into (map (_type (eql hash-table))) - "Convert MAP into a hash-table." - (map--into-hash map (list :size (map-length map) :test 'equal))) + "Convert MAP into a hash-table with keys compared with `equal'." + (map--into-hash map (list :size (map-length map) :test #'equal))) (cl-defmethod map-into (map (type (head hash-table))) "Convert MAP into a hash-table. -TYPE is a list where the car is `hash-table' and the cdr are the +TYPE is a list whose car is `hash-table' and cdr a list of keyword-args forwarded to `make-hash-table'. Example: @@ -487,23 +519,23 @@ Example: (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." - (seq-map (lambda (elt) - (cond ((consp elt) - `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) - ((keywordp elt) - (let ((var (intern (substring (symbol-name elt) 1)))) - `(app (pcase--flip map-elt ,elt) ,var))) - (t `(app (pcase--flip map-elt ',elt) ,elt)))) - args)) + (mapcar (lambda (elt) + (cond ((consp elt) + `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (pcase--flip map-elt ,elt) ,var))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) + args)) (defun map--make-pcase-patterns (args) "Return a list of `(map ...)' pcase patterns built from ARGS." (cons 'map - (seq-map (lambda (elt) - (if (and (consp elt) (eq 'map (car elt))) - (map--make-pcase-patterns elt) - elt)) - args))) + (mapcar (lambda (elt) + (if (eq (car-safe elt) 'map) + (map--make-pcase-patterns elt) + elt)) + args))) (provide 'map) ;;; map.el ends here diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index adfce950176..2b8807faad5 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -134,9 +134,10 @@ Unlike `seq-map', FUNCTION takes two arguments: the element of the sequence, and its index within the sequence." (let ((index 0)) (seq-do (lambda (elt) - (funcall function elt index) - (setq index (1+ index))) - sequence))) + (funcall function elt index) + (setq index (1+ index))) + sequence)) + nil) (cl-defgeneric seqp (object) "Return non-nil if OBJECT is a sequence, nil otherwise." diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 9a2cd42a211..67666d8e7e7 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -22,7 +22,7 @@ ;;; Commentary: -;; Tests for map.el +;; Tests for map.el. ;;; Code: @@ -30,12 +30,10 @@ (require 'map) (defmacro with-maps-do (var &rest body) - "Successively bind VAR to an alist, vector and hash-table. + "Successively bind VAR to an alist, plist, vector, and hash-table. Each map is built from the following alist data: -'((0 . 3) (1 . 4) (2 . 5)). -Evaluate BODY for each created map. - -\(fn (var map) body)" + \\='((0 . 3) (1 . 4) (2 . 5)). +Evaluate BODY for each created map." (declare (indent 1) (debug (symbolp body))) (let ((alist (make-symbol "alist")) (plist (make-symbol "plist")) @@ -53,43 +51,62 @@ Evaluate BODY for each created map. (dolist (,var (list ,alist ,plist ,vec ,ht)) ,@body)))) +(defmacro with-empty-maps-do (var &rest body) + "Like `with-maps-do', but with empty maps." + (declare (indent 1) (debug (symbolp body))) + `(dolist (,var (list (list) (vector) (make-hash-table))) + ,@body)) + +(ert-deftest test-map-plist-p () + "Test `map--plist-p'." + (with-empty-maps-do map + (should-not (map--plist-p map))) + (should-not (map--plist-p "")) + (should-not (map--plist-p '((())))) + (should (map--plist-p '(:a))) + (should (map--plist-p '(a))) + (should (map--plist-p '(nil))) + (should (map--plist-p '("")))) + (ert-deftest test-map-elt () (with-maps-do map (should (= 3 (map-elt map 0))) (should (= 4 (map-elt map 1))) (should (= 5 (map-elt map 2))) - (should (null (map-elt map -1))) - (should (null (map-elt map 4))))) + (should-not (map-elt map -1)) + (should-not (map-elt map 4)) + (should-not (map-elt map 0.1)))) (ert-deftest test-map-elt-default () (with-maps-do map - (should (= 5 (map-elt map 7 5))))) + (should (= 5 (map-elt map 7 5))) + (should (= 5 (map-elt map 0.1 5)))) + (with-empty-maps-do map + (should (= 5 (map-elt map 0 5))))) (ert-deftest test-map-elt-testfn () (let ((map (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) (should-not (map-elt map noneq-key)) - (should (map-elt map noneq-key nil 'equal)))) + (should (map-elt map noneq-key nil #'equal)))) (ert-deftest test-map-elt-with-nil-value () - (should (null (map-elt '((a . 1) - (b)) - 'b - '2)))) + (should-not (map-elt '((a . 1) (b)) 'b 2))) (ert-deftest test-map-put! () (with-maps-do map (setf (map-elt map 2) 'hello) (should (eq (map-elt map 2) 'hello))) (with-maps-do map - (map-put map 2 'hello) + (with-suppressed-warnings ((obsolete map-put)) + (map-put map 2 'hello)) (should (eq (map-elt map 2) 'hello))) (with-maps-do map (map-put! map 2 'hello) (should (eq (map-elt map 2) 'hello)) (if (not (or (hash-table-p map) - (and (listp map) (not (listp (car map)))))) ;plist! + (map--plist-p map))) (should-error (map-put! map 5 'value) ;; For vectors, it could arguably signal ;; map-not-inplace as well, but it currently doesn't. @@ -97,49 +114,88 @@ Evaluate BODY for each created map. 'map-not-inplace 'error)) (map-put! map 5 'value) - (should (eq (map-elt map 5) 'value)))) - (let ((ht (make-hash-table))) - (setf (map-elt ht 2) 'a) - (should (eq (map-elt ht 2) - 'a))) - (let ((alist '((0 . a) (1 . b) (2 . c)))) - (setf (map-elt alist 2) 'a) - (should (eq (map-elt alist 2) - 'a))) - (let ((vec [3 4 5])) - (should-error (setf (map-elt vec 3) 6)))) + (should (eq (map-elt map 5) 'value))))) + +(ert-deftest test-map-put!-new-keys () + "Test `map-put!' with new keys." + (with-maps-do map + (let ((size (map-length map))) + (if (arrayp map) + (progn + (should-error (setf (map-elt map 'k) 'v)) + (should-error (setf (map-elt map size) 'v))) + (setf (map-elt map 'k) 'v) + (should (eq (map-elt map 'k) 'v)) + (setf (map-elt map size) 'v) + (should (eq (map-elt map size) 'v)))))) (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." - (let ((alist '((0 . a)))) - (map-put alist 2 'b) - (should (eq (map-elt alist 2) - 'b)))) + (let ((alist (list (cons 0 'a)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist 2 'b)) + (should (eq (map-elt alist 2) 'b)))) (ert-deftest test-map-put-testfn-alist () (let ((alist (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) - (map-put alist noneq-key 3 #'equal) - (should-not (cddr alist)) - (map-put alist noneq-key 9 #'eql) - (should (cddr alist)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist noneq-key 3 #'equal) + (should-not (cddr alist)) + (map-put alist noneq-key 9 #'eql) + (should (cddr alist))))) (ert-deftest test-map-put-return-value () (let ((ht (make-hash-table))) - (should (eq (map-put ht 'a 'hello) 'hello)))) + (with-suppressed-warnings ((obsolete map-put)) + (should (eq (map-put ht 'a 'hello) 'hello))))) + +(ert-deftest test-map-insert-empty () + "Test `map-insert' on empty maps." + (with-empty-maps-do map + (if (arrayp map) + (should-error (map-insert map 0 6)) + (let ((new (map-insert map 0 6))) + (should-not (eq map new)) + (should-not (map-pairs map)) + (should (= (map-elt new 0) 6)))))) + +(ert-deftest test-map-insert () + "Test `map-insert'." + (with-maps-do map + (let ((pairs (map-pairs map)) + (size (map-length map)) + (new (map-insert map 0 6))) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new 0) 6)) + (if (arrayp map) + (should-error (map-insert map size 7)) + (setq new (map-insert map size 7)) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new size) 7)))))) (ert-deftest test-map-delete () (with-maps-do map - (map-delete map 1) - (should (null (map-elt map 1)))) + (should (map-elt map 1)) + (should (eq map (map-delete map 1))) + (should-not (map-elt map 1))) (with-maps-do map - (map-delete map -2) - (should (null (map-elt map -2))))) + (should-not (map-elt map -2)) + (should (eq map (map-delete map -2))) + (should-not (map-elt map -2))) + (with-maps-do map + ;; Check for OBOE. + (let ((key (map-length map))) + (should-not (map-elt map key)) + (should (eq map (map-delete map key))) + (should-not (map-elt map key))))) -(ert-deftest test-map-delete-return-value () - (let ((ht (make-hash-table))) - (should (eq (map-delete ht 'a) ht)))) +(ert-deftest test-map-delete-empty () + (with-empty-maps-do map + (should (eq map (map-delete map t))))) (ert-deftest test-map-nested-elt () (let ((vec [a b [c d [e f]]])) @@ -149,8 +205,9 @@ Evaluate BODY for each created map. (d . 3) (e . ((f . 4) (g . 5)))))))) - (should (eq (map-nested-elt alist '(b e f)) - 4))) + (should (eq (map-nested-elt alist '(b e f)) 4))) + (let ((plist '(a 1 b (c 2 d 3 e (f 4 g 5))))) + (should (eq (map-nested-elt plist '(b e f)) 4))) (let ((ht (make-hash-table))) (setf (map-elt ht 'a) 1) (setf (map-elt ht 'b) (make-hash-table)) @@ -160,214 +217,238 @@ Evaluate BODY for each created map. (ert-deftest test-map-nested-elt-default () (let ((vec [a b [c d]])) - (should (null (map-nested-elt vec '(2 3)))) - (should (null (map-nested-elt vec '(2 1 1)))) + (should-not (map-nested-elt vec '(2 3))) + (should-not (map-nested-elt vec '(2 1 1))) (should (= 4 (map-nested-elt vec '(2 1 1) 4))))) (ert-deftest test-mapp () - (should (mapp nil)) - (should (mapp '((a . b) (c . d)))) - (should (mapp '(a b c d))) - (should (mapp [])) - (should (mapp [1 2 3])) - (should (mapp (make-hash-table))) + (with-empty-maps-do map + (should (mapp map))) + (with-maps-do map + (should (mapp map))) + (should (mapp "")) (should (mapp "hello")) - (should (not (mapp 1))) - (should (not (mapp 'hello)))) + (should-not (mapp 1)) + (should-not (mapp 'hello))) (ert-deftest test-map-keys () (with-maps-do map (should (equal (map-keys map) '(0 1 2)))) - (should (null (map-keys nil))) - (should (null (map-keys [])))) + (with-empty-maps-do map + (should-not (map-keys map)))) (ert-deftest test-map-values () (with-maps-do map - (should (equal (map-values map) '(3 4 5))))) + (should (equal (map-values map) '(3 4 5)))) + (with-empty-maps-do map + (should-not (map-values map)))) (ert-deftest test-map-pairs () (with-maps-do map - (should (equal (map-pairs map) '((0 . 3) - (1 . 4) - (2 . 5)))))) + (should (equal (map-pairs map) + '((0 . 3) + (1 . 4) + (2 . 5))))) + (with-empty-maps-do map + (should-not (map-pairs map)))) (ert-deftest test-map-length () - (let ((ht (make-hash-table))) - (puthash 'a 1 ht) - (puthash 'b 2 ht) - (puthash 'c 3 ht) - (puthash 'd 4 ht) - (should (= 0 (map-length nil))) - (should (= 0 (map-length []))) - (should (= 0 (map-length (make-hash-table)))) - (should (= 5 (map-length [0 1 2 3 4]))) - (should (= 2 (map-length '((a . 1) (b . 2))))) - (should (= 4 (map-length ht))))) + (with-empty-maps-do map + (should (zerop (map-length map)))) + (with-maps-do map + (should (= 3 (map-length map)))) + (should (= 1 (map-length '(nil 1)))) + (should (= 2 (map-length '(nil 1 t 2)))) + (should (= 2 (map-length '((a . 1) (b . 2))))) + (should (= 5 (map-length [0 1 2 3 4]))) + (should (= 4 (map-length #s(hash-table data (a 1 b 2 c 3 d 4)))))) (ert-deftest test-map-copy () (with-maps-do map (let ((copy (map-copy map))) - (should (equal (map-keys map) (map-keys copy))) - (should (equal (map-values map) (map-values copy))) - (should (not (eq map copy)))))) + (should (equal (map-pairs map) (map-pairs copy))) + (should-not (eq map copy)) + (map-put! map 0 0) + (should-not (equal (map-pairs map) (map-pairs copy))))) + (with-empty-maps-do map + (should-not (map-pairs (map-copy map))))) + +(ert-deftest test-map-copy-alist () + "Test use of `copy-alist' for alists." + (let* ((cons (list 'a 1 2)) + (alist (list cons)) + (copy (map-copy alist))) + (setcar cons 'b) + (should (equal alist '((b 1 2)))) + (should (equal copy '((a 1 2)))) + (setcar (cdr cons) 0) + (should (equal alist '((b 0 2)))) + (should (equal copy '((a 0 2)))) + (setcdr cons 3) + (should (equal alist '((b . 3)))) + (should (equal copy '((a 0 2)))))) (ert-deftest test-map-apply () - (with-maps-do map - (should (equal (map-apply (lambda (k v) (cons (int-to-string k) v)) - map) - '(("0" . 3) ("1" . 4) ("2" . 5))))) - (let ((vec [a b c])) - (should (equal (map-apply (lambda (k v) (cons (1+ k) v)) - vec) - '((1 . a) - (2 . b) - (3 . c)))))) + (let ((fn (lambda (k v) (cons (number-to-string k) v)))) + (with-maps-do map + (should (equal (map-apply fn map) + '(("0" . 3) ("1" . 4) ("2" . 5))))) + (with-empty-maps-do map + (should-not (map-apply fn map))))) (ert-deftest test-map-do () - (with-maps-do map - (let ((result nil)) - (map-do (lambda (k v) - (push (list (int-to-string k) v) result)) - map) - (should (equal result '(("2" 5) ("1" 4) ("0" 3))))))) + (let* (res + (fn (lambda (k v) + (push (list (number-to-string k) v) res)))) + (with-empty-maps-do map + (should-not (map-do fn map)) + (should-not res)) + (with-maps-do map + (setq res nil) + (should-not (map-do fn map)) + (should (equal res '(("2" 5) ("1" 4) ("0" 3))))))) (ert-deftest test-map-keys-apply () (with-maps-do map - (should (equal (map-keys-apply (lambda (k) (int-to-string k)) - map) - '("0" "1" "2")))) - (let ((vec [a b c])) - (should (equal (map-keys-apply (lambda (k) (1+ k)) - vec) - '(1 2 3))))) + (should (equal (map-keys-apply #'1+ map) '(1 2 3)))) + (with-empty-maps-do map + (let (ks) + (should-not (map-keys-apply (lambda (k) (push k ks)) map)) + (should-not ks)))) (ert-deftest test-map-values-apply () (with-maps-do map - (should (equal (map-values-apply (lambda (v) (1+ v)) - map) - '(4 5 6)))) - (let ((vec [a b c])) - (should (equal (map-values-apply (lambda (v) (symbol-name v)) - vec) - '("a" "b" "c"))))) + (should (equal (map-values-apply #'1+ map) '(4 5 6)))) + (with-empty-maps-do map + (let (vs) + (should-not (map-values-apply (lambda (v) (push v vs)) map)) + (should-not vs)))) (ert-deftest test-map-filter () (with-maps-do map - (should (equal (map-keys (map-filter (lambda (_k v) - (<= 4 v)) - map)) - '(1 2))) - (should (null (map-filter (lambda (k _v) - (eq 'd k)) - map)))) - (should (null (map-filter (lambda (_k v) - (eq 3 v)) - [1 2 4 5]))) - (should (equal (map-filter (lambda (k _v) - (eq 3 k)) - [1 2 4 5]) - '((3 . 5))))) + (should (equal (map-filter (lambda (_k v) (> v 3)) map) + '((1 . 4) (2 . 5)))) + (should (equal (map-filter #'always map) (map-pairs map))) + (should-not (map-filter #'ignore map))) + (with-empty-maps-do map + (should-not (map-filter #'always map)) + (should-not (map-filter #'ignore map)))) (ert-deftest test-map-remove () (with-maps-do map - (should (equal (map-keys (map-remove (lambda (_k v) - (>= v 4)) - map)) - '(0))) - (should (equal (map-keys (map-remove (lambda (k _v) - (eq 'd k)) - map)) - (map-keys map)))) - (should (equal (map-remove (lambda (_k v) - (eq 3 v)) - [1 2 4 5]) - '((0 . 1) - (1 . 2) - (2 . 4) - (3 . 5)))) - (should (null (map-remove (lambda (k _v) - (>= k 0)) - [1 2 4 5])))) + (should (equal (map-remove (lambda (_k v) (> v 3)) map) + '((0 . 3)))) + (should (equal (map-remove #'ignore map) (map-pairs map))) + (should-not (map-remove #'always map))) + (with-empty-maps-do map + (should-not (map-remove #'always map)) + (should-not (map-remove #'ignore map)))) (ert-deftest test-map-empty-p () - (should (map-empty-p nil)) - (should (not (map-empty-p '((a . b) (c . d))))) - (should (map-empty-p [])) - (should (not (map-empty-p [1 2 3]))) - (should (map-empty-p (make-hash-table))) - (should (not (map-empty-p "hello"))) - (should (map-empty-p ""))) + (with-empty-maps-do map + (should (map-empty-p map))) + (should (map-empty-p "")) + (should-not (map-empty-p '((a . b) (c . d)))) + (should-not (map-empty-p [1 2 3])) + (should-not (map-empty-p "hello"))) (ert-deftest test-map-contains-key () - (should (map-contains-key '((a . 1) (b . 2)) 'a)) - (should (not (map-contains-key '((a . 1) (b . 2)) 'c))) - (should (map-contains-key '(("a" . 1)) "a")) - (should (not (map-contains-key '(("a" . 1)) "a" #'eq))) - (should (map-contains-key [a b c] 2)) - (should (not (map-contains-key [a b c] 3)))) + (with-empty-maps-do map + (should-not (map-contains-key map -1)) + (should-not (map-contains-key map 0)) + (should-not (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map)))) + (with-maps-do map + (should-not (map-contains-key map -1)) + (should (map-contains-key map 0)) + (should (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map))))) + +(ert-deftest test-map-contains-key-testfn () + "Test `map-contains-key' under different equalities." + (let ((key (string ?a)) + (plist '("a" 1 a 2)) + (alist '(("a" . 1) (a . 2)))) + (should (map-contains-key alist 'a)) + (should (map-contains-key plist 'a)) + (should (map-contains-key alist 'a #'eq)) + (should (map-contains-key plist 'a #'eq)) + (should (map-contains-key alist key)) + (should-not (map-contains-key plist key)) + (should-not (map-contains-key alist key #'eq)) + (should-not (map-contains-key plist key #'eq)))) (ert-deftest test-map-some () (with-maps-do map - (should (map-some (lambda (k _v) - (eq 1 k)) - map)) - (should-not (map-some (lambda (k _v) - (eq 'd k)) - map))) - (let ((vec [a b c])) - (should (map-some (lambda (k _v) - (> k 1)) - vec)) - (should-not (map-some (lambda (k _v) - (> k 3)) - vec)))) + (should (eq (map-some (lambda (k _v) (and (= k 1) 'found)) map) + 'found)) + (should-not (map-some #'ignore map))) + (with-empty-maps-do map + (should-not (map-some #'always map)) + (should-not (map-some #'ignore map)))) (ert-deftest test-map-every-p () (with-maps-do map - (should (map-every-p (lambda (k _v) - k) - map)) - (should (not (map-every-p (lambda (_k _v) - nil) - map)))) - (let ((vec [a b c])) - (should (map-every-p (lambda (k _v) - (>= k 0)) - vec)) - (should (not (map-every-p (lambda (k _v) - (> k 3)) - vec))))) + (should (map-every-p #'always map)) + (should-not (map-every-p #'ignore map)) + (should-not (map-every-p (lambda (k _v) (zerop k)) map))) + (with-empty-maps-do map + (should (map-every-p #'always map)) + (should (map-every-p #'ignore map)) + (should (map-every-p (lambda (k _v) (zerop k)) map)))) (ert-deftest test-map-into () - (let* ((alist '((a . 1) (b . 2))) + (let* ((plist '(a 1 b 2)) + (alist '((a . 1) (b . 2))) (ht (map-into alist 'hash-table)) (ht2 (map-into alist '(hash-table :test equal)))) (should (hash-table-p ht)) - (should (equal (map-into (map-into alist 'hash-table) 'list) - alist)) - (should (listp (map-into ht 'list))) - (should (equal (map-keys (map-into (map-into ht 'list) 'hash-table)) - (map-keys ht))) - (should (equal (map-values (map-into (map-into ht 'list) 'hash-table)) - (map-values ht))) + (should (equal (map-into ht 'list) alist)) + (should (equal (map-pairs (map-into (map-into ht 'list) 'hash-table)) + (map-pairs ht))) (should (equal (map-into ht 'alist) (map-into ht2 'alist))) - (should (eq (hash-table-test ht2) 'equal)) - (should (null (map-into nil 'list))) - (should (map-empty-p (map-into nil 'hash-table))) - (should-error (map-into [1 2 3] 'string)))) + (should (equal (map-into alist 'list) alist)) + (should (equal (map-into alist 'alist) alist)) + (should (equal (map-into alist 'plist) plist)) + (should (equal (map-into plist 'alist) alist)) + (should (equal (map-into plist 'plist) plist))) + (should-error (map-into [1 2 3] 'string) :type 'cl-no-applicable-method)) + +(ert-deftest test-map-into-hash-test () + "Test `map-into' with different hash-table test functions." + (should (eq (hash-table-test (map-into () 'hash-table)) #'equal)) + (should (eq (hash-table-test (map-into () '(hash-table))) #'eql)) + (should (eq (hash-table-test (map-into () '(hash-table :test eq))) #'eq)) + (should (eq (hash-table-test (map-into () '(hash-table :test eql))) #'eql)) + (should (eq (hash-table-test (map-into () '(hash-table :test equal))) + #'equal))) + +(ert-deftest test-map-into-empty () + "Test `map-into' with empty maps." + (with-empty-maps-do map + (should-not (map-into map 'list)) + (should-not (map-into map 'alist)) + (should-not (map-into map 'plist)) + (should (map-empty-p (map-into map 'hash-table))))) (ert-deftest test-map-let () (map-let (foo bar baz) '((foo . 1) (bar . 2)) (should (= foo 1)) (should (= bar 2)) - (should (null baz))) + (should-not baz)) (map-let (('foo a) ('bar b) ('baz c)) '((foo . 1) (bar . 2)) (should (= a 1)) (should (= b 2)) - (should (null c)))) + (should-not c))) + +(ert-deftest test-map-merge () + "Test `map-merge'." + (should (equal (map-merge 'list '(a 1) '((b . 2) (c . 3)) + #s(hash-table data (c 4))) + '((c . 4) (b . 2) (a . 1))))) (ert-deftest test-map-merge-with () (should (equal (map-merge-with 'list #'+ @@ -376,6 +457,19 @@ Evaluate BODY for each created map. '((1 . 1) (2 . 5) (3 . 0))) '((3 . 0) (2 . 9) (1 . 6))))) +(ert-deftest test-map-merge-empty () + "Test merging of empty maps." + (should-not (map-merge 'list)) + (should-not (map-merge 'alist)) + (should-not (map-merge 'plist)) + (should-not (map-merge-with 'list #'+)) + (should-not (map-merge-with 'alist #'+)) + (should-not (map-merge-with 'plist #'+)) + (should (map-empty-p (map-merge 'hash-table))) + (should (map-empty-p (map-merge-with 'hash-table #'+))) + (should-error (map-merge 'array) :type 'cl-no-applicable-method) + (should-error (map-merge-with 'array #'+) :type 'cl-no-applicable-method)) + (ert-deftest test-map-plist-pcase () (let ((plist '(:one 1 :two 2))) (should (equal (pcase-let (((map :one (:two two)) plist)) -- cgit v1.2.3 From cd5dfa086d204c01791bfdcdf9fe1215c4bf1e42 Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Sat, 3 Apr 2021 01:21:32 +0200 Subject: Replace two functions with seq-subseq * lisp/emacs-lisp/seq.el (seq-subseq): Add autoload cookie. * lisp/eshell/esh-util.el (eshell-sublist): Redefine using seq-subseq and make obsolete. Update callers. * lisp/wid-edit.el (widget-sublist): Redefine as obsolete function alias for seq-subseq. Update callers. --- lisp/emacs-lisp/seq.el | 1 + lisp/eshell/em-hist.el | 2 +- lisp/eshell/esh-util.el | 20 ++++++++------------ lisp/wid-edit.el | 19 +++++-------------- 4 files changed, 15 insertions(+), 27 deletions(-) (limited to 'lisp/emacs-lisp/seq.el') diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 2b8807faad5..f2f7d677e88 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -147,6 +147,7 @@ the sequence, and its index within the sequence." "Return a shallow copy of SEQUENCE." (copy-sequence sequence)) +;;;###autoload (cl-defgeneric seq-subseq (sequence start &optional end) "Return the sequence of elements of SEQUENCE from START to END. END is exclusive. diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index b7b1778ebb1..e559f5b39fe 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -758,7 +758,7 @@ matched." (setq nth (eshell-hist-word-reference nth))) (unless (numberp mth) (setq mth (eshell-hist-word-reference mth))) - (cons (mapconcat #'identity (eshell-sublist textargs nth mth) " ") + (cons (mapconcat #'identity (seq-subseq textargs nth (1+ mth)) " ") end)))) (defun eshell-hist-parse-modifier (hist reference) diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 8ef1ac9c345..1dcbed3d961 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -223,18 +223,6 @@ then quoting is done by a backslash, rather than a doubled delimiter." (string-to-number string) string)))))) -(defun eshell-sublist (l &optional n m) - "Return from LIST the N to M elements. -If N or M is nil, it means the end of the list." - (let ((a (copy-sequence l))) - (if (and m (consp (nthcdr m a))) - (setcdr (nthcdr m a) nil)) - (if n - (setq a (nthcdr n a)) - (setq n (1- (length a)) - a (last a))) - a)) - (defvar-local eshell-path-env (getenv "PATH") "Content of $PATH. It might be different from \(getenv \"PATH\"), when @@ -710,9 +698,17 @@ gid format. Valid values are `string' and `integer', defaulting to ; (or result ; (file-attributes filename)))) +;; Obsolete. + (define-obsolete-function-alias 'eshell-copy-tree #'copy-tree "28.1") (define-obsolete-function-alias 'eshell-user-name #'user-login-name "28.1") +(defun eshell-sublist (l &optional n m) + "Return from LIST the N to M elements. +If N or M is nil, it means the end of the list." + (declare (obsolete seq-subseq "28.1")) + (seq-subseq l n (1+ m))) + (provide 'esh-util) ;;; esh-util.el ends here diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index e71290c7ef9..51c6b49e6df 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1878,20 +1878,9 @@ as the argument to `documentation-property'." (let ((value (widget-get widget :value))) (and (listp value) (<= (length value) (length vals)) - (let ((head (widget-sublist vals 0 (length value)))) + (let ((head (seq-subseq vals 0 (length value)))) (and (equal head value) - (cons head (widget-sublist vals (length value)))))))) - -(defun widget-sublist (list start &optional end) - "Return the sublist of LIST from START to END. -If END is omitted, it defaults to the length of LIST." - (if (> start 0) (setq list (nthcdr start list))) - (if end - (unless (<= end start) - (setq list (copy-sequence list)) - (setcdr (nthcdr (- end start 1) list) nil) - list) - (copy-sequence list))) + (cons head (seq-subseq vals (length value)))))))) (defun widget-item-action (widget &optional event) ;; Just notify itself. @@ -4117,7 +4106,9 @@ is inline." (setq help-echo (funcall help-echo widget))) (if help-echo (message "%s" (eval help-echo))))) -;;; The End: +;;; Obsolete. + +(define-obsolete-function-alias 'widget-sublist #'seq-subseq "28.1") (provide 'wid-edit) -- cgit v1.2.3 From 20f7fa691b7c2859b96550d9ccb326bf394e160d Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Mon, 5 Apr 2021 14:24:00 +0200 Subject: Obsolete local set difference functions in favor of seq-difference * lisp/emacs-lisp/seq.el (seq-difference): Add autoload cookie. * lisp/gnus/gnus-range.el (gnus-set-difference): * lisp/gnus/spam.el (spam-set-difference): Make obsolete in favor of seq-difference. Update callers. --- lisp/emacs-lisp/seq.el | 1 + lisp/gnus/gnus-cite.el | 4 ++-- lisp/gnus/gnus-range.el | 9 ++------- lisp/gnus/gnus-sum.el | 5 +++-- lisp/gnus/gnus-uu.el | 2 +- lisp/gnus/nnimap.el | 10 ++++++---- lisp/gnus/spam.el | 14 +++----------- 7 files changed, 18 insertions(+), 27 deletions(-) (limited to 'lisp/emacs-lisp/seq.el') diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index f2f7d677e88..7aa5684cfd1 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -468,6 +468,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (seq-reverse sequence1) '())) +;;;###autoload (cl-defgeneric seq-difference (sequence1 sequence2 &optional testfn) "Return a list of the elements that appear in SEQUENCE1 but not in SEQUENCE2. Equality is defined by TESTFN if non-nil or by `equal' if nil." diff --git a/lisp/gnus/gnus-cite.el b/lisp/gnus/gnus-cite.el index 1f564f192b0..4249b50b9ff 100644 --- a/lisp/gnus/gnus-cite.el +++ b/lisp/gnus/gnus-cite.el @@ -839,7 +839,7 @@ See also the documentation for `gnus-article-highlight-citation'." (setq current (car loop) loop (cdr loop)) (setcdr current - (gnus-set-difference (cdr current) numbers))))))))) + (seq-difference (cdr current) numbers #'eq))))))))) (defun gnus-cite-parse-attributions () (let (al-alist) @@ -999,7 +999,7 @@ See also the documentation for `gnus-article-highlight-citation'." loop (cdr loop)) (if (eq current best) () - (setcdr current (gnus-set-difference (cdr current) numbers)) + (setcdr current (seq-difference (cdr current) numbers #'eq)) (when (null (cdr current)) (setq gnus-cite-loose-prefix-alist (delq current gnus-cite-loose-prefix-alist) diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index 456209f3d9a..7d12ae9fdcc 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -42,13 +42,8 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE." (defun gnus-set-difference (list1 list2) "Return a list of elements of LIST1 that do not appear in LIST2." - (let ((hash2 (make-hash-table :test 'eq)) - (result nil)) - (dolist (elt list2) (puthash elt t hash2)) - (dolist (elt list1) - (unless (gethash elt hash2) - (setq result (cons elt result)))) - (nreverse result))) + (declare (obsolete seq-difference "28.1")) + (seq-difference list1 list2 #'eq)) (defun gnus-range-nconcat (&rest ranges) "Return a range comprising all the RANGES, which are pre-sorted. diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index ac9317ef4e2..eeb5ac851ae 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -8569,8 +8569,9 @@ If UNREPLIED (the prefix), limit to unreplied articles." (interactive "P" gnus-summary-mode) (if unreplied (gnus-summary-limit - (gnus-set-difference gnus-newsgroup-articles - gnus-newsgroup-replied)) + (seq-difference gnus-newsgroup-articles + gnus-newsgroup-replied + #'eq)) (gnus-summary-limit gnus-newsgroup-replied)) (gnus-summary-position-point)) diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 5cbe8495d31..ceb2ebcdcb1 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -579,7 +579,7 @@ didn't work, and overwrite existing files. Otherwise, ask each time." (defun gnus-new-processable (unmarkp articles) (if unmarkp (nreverse (seq-intersection gnus-newsgroup-processable articles #'eq)) - (gnus-set-difference articles gnus-newsgroup-processable))) + (seq-difference articles gnus-newsgroup-processable #'eq))) (defun gnus-uu-mark-by-regexp (regexp &optional unmark) "Set the process mark on articles whose subjects match REGEXP. diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index f06959f65d9..8990b2bebeb 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1614,13 +1614,15 @@ If LIMIT, first try to limit the search to the N last articles." (setq start-article 1)) (let* ((unread (gnus-compress-sequence - (gnus-set-difference - (gnus-set-difference + (seq-difference + (seq-difference existing (gnus-sorted-union (cdr (assoc '%Seen flags)) - (cdr (assoc '%Deleted flags)))) - (cdr (assoc '%Flagged flags))))) + (cdr (assoc '%Deleted flags))) + #'eq) + (cdr (assoc '%Flagged flags)) + #'eq))) (read (gnus-range-difference (cons start-article high) unread))) (when (> start-article 1) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index d00f0a60b66..3f978918b9a 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -710,16 +710,8 @@ finds ham or spam.") (defun spam-set-difference (list1 list2) "Return a set difference of LIST1 and LIST2. When either list is nil, the other is returned." - (if (and list1 list2) - ;; we have two non-nil lists - (progn - (dolist (item (append list1 list2)) - (when (and (memq item list1) (memq item list2)) - (setq list1 (delq item list1)) - (setq list2 (delq item list2)))) - (append list1 list2)) - ;; if either of the lists was nil, return the other one - (if list1 list1 list2))) + (declare (obsolete seq-difference "28.1")) + (seq-difference list1 list2 #'eq)) (defun spam-group-ham-mark-p (group mark &optional spam) "Checks if MARK is considered a ham mark in GROUP." @@ -1327,7 +1319,7 @@ In the case of mover backends, checks the setting of (new-articles (spam-list-articles gnus-newsgroup-articles classification)) - (changed-articles (spam-set-difference new-articles old-articles))) + (changed-articles (seq-difference new-articles old-articles #'eq))) ;; now that we have the changed articles, we go through the processors (dolist (backend (spam-backend-list)) (let (unregister-list) -- cgit v1.2.3 From 6686a31591d2d22a4d1c7b6e68a618823186c48e Mon Sep 17 00:00:00 2001 From: Stefan Kangas Date: Mon, 5 Apr 2021 15:14:19 +0200 Subject: Remove local uniquify functions in favour of seq-uniq * lisp/emacs-lisp/seq.el (seq-uniq): Add autoload cookie. * lisp/pcomplete.el: (pcomplete-uniquify-list): Use seq-uniq. * lisp/eshell/esh-util.el (eshell-uniqify-list) (eshell-uniquify-list): * lisp/nxml/rng-util.el (rng-uniquify-equal): * lisp/progmodes/idlwave.el (idlwave-uniquify): * lisp/textmodes/artist.el (artist-uniq): Make into obsolete function aliases for seq-uniq. Update callers. * lisp/nxml/rng-util.el (rng-uniquify-eq): Make obsolete in favor of seq-uniq. Update callers. --- lisp/emacs-lisp/seq.el | 1 + lisp/eshell/em-pred.el | 2 +- lisp/eshell/esh-util.el | 16 ++-------------- lisp/nxml/rng-loc.el | 2 +- lisp/nxml/rng-match.el | 2 +- lisp/nxml/rng-nxml.el | 2 +- lisp/nxml/rng-util.el | 28 ++++++++-------------------- lisp/pcomplete.el | 15 +++------------ lisp/progmodes/idlwave.el | 12 +++--------- lisp/textmodes/artist.el | 14 ++------------ 10 files changed, 23 insertions(+), 71 deletions(-) (limited to 'lisp/emacs-lisp/seq.el') diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 7aa5684cfd1..6c15463ad52 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -431,6 +431,7 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." (setq index (1+ index))) nil))) +;;;###autoload (cl-defgeneric seq-uniq (sequence &optional testfn) "Return a list of the elements of SEQUENCE with duplicates removed. TESTFN is used to compare elements, or `equal' if TESTFN is nil." diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index b0a7544bdab..0780d6ee83a 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -130,7 +130,7 @@ The format of each entry is (?e . (lambda (lst) (mapcar #'file-name-extension lst))) (?t . (lambda (lst) (mapcar #'file-name-nondirectory lst))) (?q . (lambda (lst) (mapcar #'eshell-escape-arg lst))) - (?u . (lambda (lst) (eshell-uniquify-list lst))) + (?u . (lambda (lst) (seq-uniq lst))) (?o . (lambda (lst) (sort lst #'string-lessp))) (?O . (lambda (lst) (nreverse (sort lst #'string-lessp)))) (?j . (eshell-join-members)) diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 1dcbed3d961..a48f62654d5 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -291,20 +291,6 @@ Prepend remote identification of `default-directory', if any." (define-obsolete-function-alias 'eshell-flatten-list #'flatten-tree "27.1") -(defun eshell-uniquify-list (l) - "Remove occurring multiples in L. You probably want to sort first." - (let ((m l)) - (while m - (while (and (cdr m) - (string= (car m) - (cadr m))) - (setcdr m (cddr m))) - (setq m (cdr m)))) - l) -(define-obsolete-function-alias - 'eshell-uniqify-list - 'eshell-uniquify-list "27.1") - (defun eshell-stringify (object) "Convert OBJECT into a string value." (cond @@ -700,6 +686,8 @@ gid format. Valid values are `string' and `integer', defaulting to ;; Obsolete. +(define-obsolete-function-alias 'eshell-uniquify-list #'seq-uniq "28.1") +(define-obsolete-function-alias 'eshell-uniqify-list #'seq-uniq "28.1") (define-obsolete-function-alias 'eshell-copy-tree #'copy-tree "28.1") (define-obsolete-function-alias 'eshell-user-name #'user-login-name "28.1") diff --git a/lisp/nxml/rng-loc.el b/lisp/nxml/rng-loc.el index d5a608d6ff2..a38da794226 100644 --- a/lisp/nxml/rng-loc.el +++ b/lisp/nxml/rng-loc.el @@ -182,7 +182,7 @@ If TYPE-ID is non-nil, then locate the schema for this TYPE-ID." (while files (setq type-ids (rng-possible-type-ids-using (car files) type-ids)) (setq files (cdr files))) - (rng-uniquify-equal (sort type-ids 'string<)))) + (seq-uniq (sort type-ids 'string<)))) (defun rng-locate-schema-file-using (files) "Locate a schema using the schema locating files FILES. diff --git a/lisp/nxml/rng-match.el b/lisp/nxml/rng-match.el index 4fc6727d0e6..7a2739c0616 100644 --- a/lisp/nxml/rng-match.el +++ b/lisp/nxml/rng-match.el @@ -472,7 +472,7 @@ list is nullable and whose cdr is the normalized list." (cons nullable (if sorted head - (rng-uniquify-eq (sort head 'rng-compare-ipattern)))))) + (seq-uniq (sort head 'rng-compare-ipattern) #'eq))))) (defun rng-compare-ipattern (p1 p2) (< (rng--ipattern-index p1) diff --git a/lisp/nxml/rng-nxml.el b/lisp/nxml/rng-nxml.el index 7ea6fb2e49d..33768a46c94 100644 --- a/lisp/nxml/rng-nxml.el +++ b/lisp/nxml/rng-nxml.el @@ -522,7 +522,7 @@ set `xmltok-dtd'. Returns the position of the end of the token." (unless attribute-flag (setcdr ns-prefixes (cons nil (cdr ns-prefixes)))))) (setq iter (cdr iter))) - (rng-uniquify-equal + (seq-uniq (sort (apply #'append (cons extra-strings (mapcar (lambda (name) diff --git a/lisp/nxml/rng-util.el b/lisp/nxml/rng-util.el index a20e95086cb..67e2ee9f1e3 100644 --- a/lisp/nxml/rng-util.el +++ b/lisp/nxml/rng-util.el @@ -36,26 +36,6 @@ (defconst rng-builtin-datatypes-uri (rng-make-datatypes-uri "")) -(defun rng-uniquify-eq (list) - "Destructively remove `eq' duplicates from LIST." - (and list - (let ((head list)) - (while (cdr head) - (if (eq (car head) (cadr head)) - (setcdr head (cddr head))) - (setq head (cdr head))) - list))) - -(defun rng-uniquify-equal (list) - "Destructively remove `equal' duplicates from LIST." - (and list - (let ((head list)) - (while (cdr head) - (if (equal (car head) (cadr head)) - (setcdr head (cddr head))) - (setq head (cdr head))) - list))) - (defun rng-blank-p (str) (string-match "\\`[ \t\n\r]*\\'" str)) (defun rng-substq (new old list) @@ -104,6 +84,14 @@ LIST is not modified." (define-error 'rng-error nil) +;; Obsolete. + +(defun rng-uniquify-eq (list) + (declare (obsolete seq-uniq "28.1")) + (seq-uniq list #'eq)) + +(define-obsolete-function-alias 'rng-uniquify-equal #'seq-uniq "28.1") + (provide 'rng-util) ;;; rng-util.el ends here diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index b648ecf0986..bffdcaa2de0 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -1260,18 +1260,9 @@ If specific documentation can't be given, be generic." (defun pcomplete-uniquify-list (l) "Sort and remove multiples in L." - (setq l (sort l 'string-lessp)) - (let ((m l)) - (while m - (while (and (cdr m) - (string= (car m) - (cadr m))) - (setcdr m (cddr m))) - (setq m (cdr m)))) - l) -(define-obsolete-function-alias - 'pcomplete-uniqify-list - 'pcomplete-uniquify-list "27.1") + (setq l (sort l #'string-lessp)) + (seq-uniq l)) +(define-obsolete-function-alias 'pcomplete-uniqify-list #'pcomplete-uniquify-list "27.1") (defun pcomplete-process-result (cmd &rest args) "Call CMD using `call-process' and return the simplest result." diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index f53f3f3b995..75f2016fc24 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -7601,15 +7601,6 @@ associated TAG, if any." (put-text-property (match-beginning 0) (match-end 0) 'face 'font-lock-string-face)))))) -(defun idlwave-uniquify (list) - (let ((ht (make-hash-table :size (length list) :test 'equal))) - (delq nil - (mapcar (lambda (x) - (unless (gethash x ht) - (puthash x t ht) - x)) - list)))) - (defun idlwave-after-successful-completion (type slash &optional verify) "Add `=' or `(' after successful completion of keyword and function. Restore the pre-completion window configuration if possible." @@ -9101,6 +9092,9 @@ This function was written since `list-abbrevs' looks terrible for IDLWAVE mode." ;; Run the hook (run-hooks 'idlwave-load-hook) +;; Obsolete. +(define-obsolete-function-alias 'idlwave-uniquify #'seq-uniq "28.1") + (provide 'idlwave) ;;; idlwave.el ends here diff --git a/lisp/textmodes/artist.el b/lisp/textmodes/artist.el index 22ade15921d..fbb9d2174fd 100644 --- a/lisp/textmodes/artist.el +++ b/lisp/textmodes/artist.el @@ -1753,13 +1753,6 @@ info-variant-part." "Call function FN with ARGS, if FN is not nil." `(if ,fn (funcall ,fn ,@args))) -(defun artist-uniq (l) - "Remove consecutive duplicates in list L. Comparison is done with `equal'." - (cond ((null l) nil) - ((null (cdr l)) l) ; only one element in list - ((equal (car l) (car (cdr l))) (artist-uniq (cdr l))) ; first 2 equal - (t (cons (car l) (artist-uniq (cdr l)))))) ; first 2 are different - (defun artist-string-split (str r) "Split string STR at occurrences of regexp R, returning a list of strings." (let ((res nil) @@ -2761,7 +2754,7 @@ to append to the end of the list, when doing free-hand drawing)." Also, the `artist-key-poly-point-list' is reversed." (setq artist-key-poly-point-list - (artist-uniq artist-key-poly-point-list)) + (seq-uniq artist-key-poly-point-list)) (if (>= (length artist-key-poly-point-list) 2) @@ -5372,10 +5365,7 @@ The event, EV, is the mouse event." (concat "Hello Tomas,\n\n" "I have a nice bug report on Artist for you! Here it is:"))))) - -;; -;; Now provide this minor mode -;; +(define-obsolete-function-alias 'artist-uniq #'seq-uniq "28.1") (provide 'artist) -- cgit v1.2.3 From 4053bd5201252850aa816150925aa256e5ab7238 Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Fri, 30 Jul 2021 13:13:46 +0200 Subject: Work around long-standing seq.el compilation warning * lisp/emacs-lisp/seq.el (seq-contains): When using cl-defgeneric to define an obsolete function, it'll complain about it being obsolete. Suppress that warning. (Should probably be fixed in cl-defgeneric instead.) --- lisp/emacs-lisp/seq.el | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) (limited to 'lisp/emacs-lisp/seq.el') diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 6c15463ad52..e8fc4a28145 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -394,14 +394,15 @@ found or not." (setq count (+ 1 count)))) count)) -(cl-defgeneric seq-contains (sequence elt &optional testfn) - "Return the first element in SEQUENCE that is equal to ELT. +(with-suppressed-warnings ((obsolete seq-contains)) + (cl-defgeneric seq-contains (sequence elt &optional testfn) + "Return the first element in SEQUENCE that is equal to ELT. Equality is defined by TESTFN if non-nil or by `equal' if nil." - (declare (obsolete seq-contains-p "27.1")) - (seq-some (lambda (e) - (when (funcall (or testfn #'equal) elt e) - e)) - sequence)) + (declare (obsolete seq-contains-p "27.1")) + (seq-some (lambda (e) + (when (funcall (or testfn #'equal) elt e) + e)) + sequence))) (cl-defgeneric seq-contains-p (sequence elt &optional testfn) "Return non-nil if SEQUENCE contains an element equal to ELT. -- cgit v1.2.3 From c58f8dda2b2282302cf47ef3e7df6523bde606f5 Mon Sep 17 00:00:00 2001 From: Earl Hyatt Date: Sat, 14 Aug 2021 14:17:12 +0200 Subject: Add macro `seq-setq`. * doc/lispref/sequences.texi (seq-setq): Document this macro. * lisp/emacs-lisp/seq.el (seq-setq): New macro. * test/lisp/emacs-lisp/seq-tests.el (test-seq-setq): Test this macro (bug#50053). --- doc/lispref/sequences.texi | 17 +++++++++++++++++ lisp/emacs-lisp/seq.el | 8 ++++++++ test/lisp/emacs-lisp/seq-tests.el | 24 ++++++++++++++++++++++++ 3 files changed, 49 insertions(+) (limited to 'lisp/emacs-lisp/seq.el') diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi index 545fd408f88..20816ce8ca2 100644 --- a/doc/lispref/sequences.texi +++ b/doc/lispref/sequences.texi @@ -1111,6 +1111,23 @@ The @code{pcase} patterns provide an alternative facility for destructuring binding, see @ref{Destructuring with pcase Patterns}. @end defmac +@defmac seq-setq var-sequence val-sequence +@cindex sequence destructuring + This macro works similarly to @code{seq-let}, except that values are +assigned to variables as if by @code{setq} instead of as in a +@code{let} binding. + +@example +@group +(let ((a nil) + (b nil)) + (seq-setq (_ a _ b) '(1 2 3 4)) + (list a b)) +@result{} (2 4) +@end group +@end example +@end defmac + @defun seq-random-elt sequence This function returns an element of @var{sequence} taken at random. diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index e8fc4a28145..f0dc283f57d 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -93,6 +93,14 @@ name to be bound to the rest of SEQUENCE." (declare (indent 2) (debug (sexp form body))) `(pcase-let ((,(seq--make-pcase-patterns args) ,sequence)) ,@body)) + +(defmacro seq-setq (args sequence) + "Assign to the variables in ARGS the elements of SEQUENCE. + +ARGS can also include the `&rest' marker followed by a variable +name to be bound to the rest of SEQUENCE." + (declare (debug (sexp form))) + `(pcase-setq ,(seq--make-pcase-patterns args) ,sequence)) ;;; Basic seq functions that have to be implemented by new sequence types diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 05c7fbe781e..44e855e2cfa 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -383,6 +383,30 @@ Evaluate BODY for each created sequence. (should (null b)) (should (null c))))) +(ert-deftest test-seq-setq () + (with-test-sequences (seq '(1 2 3 4)) + (let (a b c d e) + (seq-setq (a b c d e) seq) + (should (= a 1)) + (should (= b 2)) + (should (= c 3)) + (should (= d 4)) + (should (null e))) + (let (a b others) + (seq-setq (a b &rest others) seq) + (should (= a 1)) + (should (= b 2)) + (should (same-contents-p others (seq-drop seq 2))))) + (let ((a) + (seq '(1 (2 (3 (4)))))) + (seq-setq (_ (_ (_ (a)))) seq) + (should (= a 4))) + (let (seq a b c) + (seq-setq (a b c) seq) + (should (null a)) + (should (null b)) + (should (null c)))) + (ert-deftest test-seq-min-max () (with-test-sequences (seq '(4 5 3 2 0 4)) (should (= (seq-min seq) 0)) -- cgit v1.2.3