[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 9da2efb670: Audit some plist uses with new predicate argument
|
From: |
Basil L. Contovounesios |
|
Subject: |
master 9da2efb670: Audit some plist uses with new predicate argument |
|
Date: |
Sat, 22 Oct 2022 12:53:31 -0400 (EDT) |
branch: master
commit 9da2efb670574b473ab864ae0456b4f1b38e680b
Author: Basil L. Contovounesios <contovob@tcd.ie>
Commit: Basil L. Contovounesios <contovob@tcd.ie>
Audit some plist uses with new predicate argument
* doc/lispref/lists.texi (Plist Access): Improve description of
default predicate.
* lisp/emacs-lisp/cl-extra.el (cl-getf, cl--set-getf): Assume
plist-member always returns a cons.
* lisp/emacs-lisp/gv.el (plist-get): Support new optional predicate
argument (bug#47425#91).
* lisp/emacs-lisp/map.el: Bump minor version.
(map--dispatch): Remove now that bug#58563 is fixed. Break two
remaining uses out into corresponding cl-defmethods.
(map--plist-p): Add docstring.
(map--plist-has-predicate, map--plist-member-1, map--plist-member)
(map--plist-put-1, map--plist-put): New definitions for supporting
predicate argument backward compatibly.
(map-elt): Fix generalized variable getter under a
predicate (bug#58531). Use predicate when given a plist.
(map-put): Avoid gratuitous warnings when called without the hidden
predicate argument. Improve obsoletion message.
(map-put!): Use predicate when given a plist.
(map-contains-key): Ditto. Declare forgotten
advertised-calling-convention (bug#58531#19).
(map--put): Group definition in file together with that of map-put!.
* lisp/files-x.el (connection-local-normalize-criteria): Simplify
using mapcan + plist-get.
* lisp/net/eudc.el (eudc--plist-member): New convenience function.
(eudc-plist-member, eudc-plist-get, eudc-lax-plist-get): Use it
instead of open-coding plist-member.
* src/fns.c (Fplist_get, plist_get, Fplist_put, plist_put): Pass the
plist element as the first argument to the predicate, for
consistency with assoc + alist-get.
(Fplist_member, plist_member): Move from widget to plist section.
Open-code the EQ case in plist_member, and call it from
Fplist_member in that case, rather than the other way around.
* test/lisp/apropos-tests.el (apropos-tests-format-plist): Avoid
polluting obarray.
* test/lisp/emacs-lisp/cl-extra-tests.el (cl-getf): Extend test with
generalized variables, degenerate plists, and improper lists.
* test/lisp/emacs-lisp/gv-tests.el: Byte-compile file; in the
meantime bug#24402 seems to have been fixed or worked around.
(gv-setter-edebug): Inhibit printing messages.
(gv-plist-get): Avoid modifying constant literals. Also test with a
predicate argument.
* test/lisp/emacs-lisp/map-tests.el (with-maps-do): Simplify
docstring.
(test-map-elt-testfn): Rename...
(test-map-elt-testfn-alist): ...to this. Also test with a predicate
argument.
(test-map-elt-testfn-plist, test-map-elt-gv, test-map-elt-signature)
(test-map-put!-plist, test-map-put!-signature)
(test-map-contains-key-signature, test-map-plist-member)
(test-map-plist-put): New tests.
(test-map-contains-key-testfn): Also test with a predicate argument.
(test-map-setf-alist-overwrite-key, test-map-setf-plist-insert-key)
(test-map-setf-plist-overwrite-key): Avoid modifying constant
literals.
(test-hash-table-setf-insert-key)
(test-hash-table-setf-overwrite-key): Fix indentation.
(test-setf-map-with-function): Make test more precise.
* test/lisp/net/eudc-tests.el: New file.
* test/lisp/subr-tests.el (test-plistp): Extend test with circular
list.
* test/src/fns-tests.el (test-cycle-equal, test-cycle-nconc): Move
from plist section to circular list section.
(plist-put/odd-number-of-elements): Avoid modifying constant
literals.
(plist-member/improper-list): Simplify.
(test-plist): Move to plist section. Also test with a predicate
argument.
---
doc/lispref/lists.texi | 8 +-
lisp/emacs-lisp/cl-extra.el | 4 +-
lisp/emacs-lisp/gv.el | 7 +-
lisp/emacs-lisp/map.el | 164 ++++++++++++++++----------
lisp/files-x.el | 11 +-
lisp/net/eudc.el | 62 +++++-----
src/fns.c | 97 +++++++++-------
test/lisp/apropos-tests.el | 17 +--
test/lisp/emacs-lisp/cl-extra-tests.el | 24 +++-
test/lisp/emacs-lisp/gv-tests.el | 75 +++++-------
test/lisp/emacs-lisp/map-tests.el | 204 +++++++++++++++++++++++++++++++--
test/lisp/net/eudc-tests.el | 155 +++++++++++++++++++++++++
test/lisp/subr-tests.el | 5 +-
test/src/fns-tests.el | 70 ++++++-----
14 files changed, 651 insertions(+), 252 deletions(-)
diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 5c5c615f85..30f65e359a 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -1961,12 +1961,12 @@ and later discarded; this is not possible with a
property list.
@cindex accessing plist properties
The following functions can be used to manipulate property lists.
-They all compare property names using @code{eq}.
+They all default to comparing property names using @code{eq}.
@defun plist-get plist property &optional predicate
This returns the value of the @var{property} property stored in the
property list @var{plist}. Comparisons are done with @var{predicate},
-and defaults to @code{eq}. It accepts a malformed @var{plist}
+which defaults to @code{eq}. It accepts a malformed @var{plist}
argument. If @var{property} is not found in the @var{plist}, it
returns @code{nil}. For example,
@@ -1985,7 +1985,7 @@ returns @code{nil}. For example,
@defun plist-put plist property value &optional predicate
This stores @var{value} as the value of the @var{property} property in
the property list @var{plist}. Comparisons are done with @var{predicate},
-and defaults to @code{eq}. It may modify @var{plist} destructively,
+which defaults to @code{eq}. It may modify @var{plist} destructively,
or it may construct a new list structure without altering the old. The
function returns the modified property list, so you can store that back
in the place where you got @var{plist}. For example,
@@ -2012,7 +2012,7 @@ compares properties using @code{equal} instead of
@code{eq}.
@defun plist-member plist property &optional predicate
This returns non-@code{nil} if @var{plist} contains the given
-@var{property}. Comparisons are done with @var{predicate}, and
+@var{property}. Comparisons are done with @var{predicate}, which
defaults to @code{eq}. Unlike @code{plist-get}, this allows you to
distinguish between a missing property and a property with the value
@code{nil}. The value is actually the tail of @var{plist} whose
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 7c7f027d77..66b214554e 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -615,12 +615,12 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
,(funcall setter
`(cl--set-getf ,getter ,k ,val))
,val)))))))))
- (let ((val-tail (cdr-safe (plist-member plist tag))))
+ (let ((val-tail (cdr (plist-member plist tag))))
(if val-tail (car val-tail) def)))
;;;###autoload
(defun cl--set-getf (plist tag val)
- (let ((val-tail (cdr-safe (plist-member plist tag))))
+ (let ((val-tail (cdr (plist-member plist tag))))
(if val-tail (progn (setcar val-tail val) plist)
(cl-list* tag val plist))))
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index a96fa19a3f..11251d7a96 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -445,16 +445,17 @@ The return value is the last VAL in the list.
,v))))))))))
(gv-define-expander plist-get
- (lambda (do plist prop)
+ (lambda (do plist prop &optional predicate)
(macroexp-let2 macroexp-copyable-p key prop
(gv-letplace (getter setter) plist
- (macroexp-let2 nil p `(cdr (plist-member ,getter ,key))
+ (macroexp-let2 nil p `(cdr (plist-member ,getter ,key ,predicate))
(funcall do
`(car ,p)
(lambda (val)
`(if ,p
(setcar ,p ,val)
- ,(funcall setter `(cons ,key (cons ,val
,getter)))))))))))
+ ,(funcall setter
+ `(cons ,key (cons ,val ,getter)))))))))))
;;; Some occasionally handy extensions.
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index 8c67d7c7a2..8e3b698d37 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -5,7 +5,7 @@
;; Author: Nicolas Petton <nicolas@petton.fr>
;; Maintainer: emacs-devel@gnu.org
;; Keywords: extensions, lisp
-;; Version: 3.2.1
+;; Version: 3.3.1
;; Package-Requires: ((emacs "26"))
;; This file is part of GNU Emacs.
@@ -80,48 +80,82 @@ MAP can be an alist, plist, hash-table, or array."
`(pcase-let ((,(map--make-pcase-patterns keys) ,map))
,@body))
-(eval-when-compile
- (defmacro map--dispatch (map-var &rest args)
- "Evaluate one of the forms specified by ARGS based on the type of MAP-VAR.
-
-The following keyword types are meaningful: `:list',
-`:hash-table' and `:array'.
-
-An error is thrown if MAP-VAR is neither a list, hash-table nor array.
-
-Returns the result of evaluating the form associated with MAP-VAR's type."
- (declare (debug t) (indent 1))
- `(cond ((listp ,map-var) ,(plist-get args :list))
- ((hash-table-p ,map-var) ,(plist-get args :hash-table))
- ((arrayp ,map-var) ,(plist-get args :array))
- (t (error "Unsupported map type `%S': %S"
- (type-of ,map-var) ,map-var)))))
-
(define-error 'map-not-inplace "Cannot modify map in-place")
(defsubst map--plist-p (list)
+ "Return non-nil if LIST is the start of a nonempty plist map."
(and (consp list) (atom (car list))))
+(defconst map--plist-has-predicate
+ (condition-case nil
+ (with-no-warnings (plist-get () nil #'eq) t)
+ (wrong-number-of-arguments))
+ "Non-nil means `plist-get' & co. accept a predicate in Emacs 29+.
+Note that support for this predicate in map.el is patchy and
+deprecated.")
+
+(defun map--plist-member-1 (plist prop &optional predicate)
+ "Compatibility shim for the PREDICATE argument of `plist-member'.
+Assumes non-nil PLIST satisfies `map--plist-p'."
+ (if (or (memq predicate '(nil eq)) (null plist))
+ (plist-member plist prop)
+ (let ((tail plist) found)
+ (while (and (not (setq found (funcall predicate (car tail) prop)))
+ (consp (setq tail (cdr tail)))
+ (consp (setq tail (cdr tail)))))
+ (and tail (not found)
+ (signal 'wrong-type-argument `(plistp ,plist)))
+ tail)))
+
+(defalias 'map--plist-member
+ (if map--plist-has-predicate #'plist-member #'map--plist-member-1)
+ "Compatibility shim for `plist-member' in Emacs 29+.
+\n(fn PLIST PROP &optional PREDICATE)")
+
+(defun map--plist-put-1 (plist prop val &optional predicate)
+ "Compatibility shim for the PREDICATE argument of `plist-put'.
+Assumes non-nil PLIST satisfies `map--plist-p'."
+ (if (or (memq predicate '(nil eq)) (null plist))
+ (plist-put plist prop val)
+ (let ((tail plist) prev found)
+ (while (and (consp (cdr tail))
+ (not (setq found (funcall predicate (car tail) prop)))
+ (consp (setq prev tail tail (cddr tail)))))
+ (cond (found (setcar (cdr tail) val))
+ (tail (signal 'wrong-type-argument `(plistp ,plist)))
+ (prev (setcdr (cdr prev) (cons prop (cons val (cddr prev)))))
+ ((setq plist (cons prop (cons val plist)))))
+ plist)))
+
+(defalias 'map--plist-put
+ (if map--plist-has-predicate #'plist-put #'map--plist-put-1)
+ "Compatibility shim for `plist-put' in Emacs 29+.
+\n(fn PLIST PROP VAL &optional PREDICATE)")
+
(cl-defgeneric map-elt (map key &optional default testfn)
"Look up KEY in MAP and return its associated value.
If KEY is not found, return DEFAULT which defaults to nil.
TESTFN is the function to use for comparing keys. It is
deprecated because its default and valid values depend on the MAP
-argument. Generally, alist keys are compared with `equal', plist
-keys with `eq', and hash-table keys with the hash-table's test
+argument, and it was never consistently supported by the map.el
+API. Generally, alist keys are compared with `equal', plist keys
+with `eq', and hash-table keys with the hash-table's test
function.
In the base definition, MAP can be an alist, plist, hash-table,
or array."
(declare
+ ;; `testfn' is deprecated.
+ (advertised-calling-convention (map key &optional default) "27.1")
(gv-expander
(lambda (do)
(gv-letplace (mgetter msetter) `(gv-delay-error ,map)
(macroexp-let2* nil
;; Eval them once and for all in the right order.
((key key) (default default) (testfn testfn))
- (funcall do `(map-elt ,mgetter ,key ,default)
+ (funcall do
+ `(map-elt ,mgetter ,key ,default ,@(and testfn `(,testfn)))
(lambda (v)
(macroexp-let2 nil v v
`(condition-case nil
@@ -132,19 +166,21 @@ or array."
,(funcall msetter
`(map-insert ,mgetter ,key ,v))
;; Always return the value.
- ,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-member map key)))
- (if res (cadr res) default))
- (alist-get key map default nil (or testfn #'equal)))
- :hash-table (gethash key map default)
- :array (if (map-contains-key map key)
- (aref map key)
- default)))
+ ,v)))))))))))
+
+(cl-defmethod map-elt ((map list) key &optional default testfn)
+ (if (map--plist-p map)
+ (let ((res (map--plist-member map key testfn)))
+ (if res (cadr res) default))
+ (alist-get key map default nil (or testfn #'equal))))
+
+(cl-defmethod map-elt ((map hash-table) key &optional default _testfn)
+ (gethash key map default))
+
+(cl-defmethod map-elt ((map array) key &optional default _testfn)
+ (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.
@@ -154,8 +190,12 @@ When MAP is an alist, test equality with TESTFN if non-nil,
otherwise use `equal'.
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))
+ (declare
+ (obsolete "use `map-put!' or `(setf (map-elt ...) ...)' instead." "27.1"))
+ (if testfn
+ `(with-no-warnings
+ (setf (map-elt ,map ,key nil ,testfn) ,value))
+ `(setf (map-elt ,map ,key) ,value)))
(defun map--plist-delete (map key)
(let ((tail map) last)
@@ -338,15 +378,16 @@ The default implementation delegates to `map-length'."
"Return non-nil if and only if MAP contains KEY.
TESTFN is deprecated. Its default depends on MAP.
The default implementation delegates to `map-some'."
+ (declare (advertised-calling-convention (map key) "27.1"))
(unless testfn (setq testfn #'equal))
(map-some (lambda (k _v) (funcall testfn key k)) map))
(cl-defmethod map-contains-key ((map list) key &optional testfn)
"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 is a plist, TESTFN defaults to `eq'."
(if (map--plist-p map)
- (plist-member map key)
+ (map--plist-member map key testfn)
(let ((v '(nil)))
(not (eq v (alist-get key map v nil (or testfn #'equal)))))))
@@ -459,24 +500,30 @@ This operates by modifying MAP in place.
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
- (progn
- (if (map--plist-p map)
- (plist-put map key value)
- (let ((oldmap map))
- (setf (alist-get key map key nil (or testfn #'equal)) value)
- (unless (eq oldmap map)
- (signal 'map-not-inplace (list oldmap)))))
- ;; Always return the value.
- value)
- :hash-table (puthash key value map)
- ;; FIXME: If `key' is too large, should we signal `map-not-inplace'
- ;; and let `map-insert' grow the array?
- :array (aset map key value)))
+ (declare (advertised-calling-convention (map key value) "27.1")))
+
+(cl-defmethod map-put! ((map list) key value &optional testfn)
+ (if (map--plist-p map)
+ (map--plist-put map key value testfn)
+ (let ((oldmap map))
+ (setf (alist-get key map key nil (or testfn #'equal)) value)
+ (unless (eq oldmap map)
+ (signal 'map-not-inplace (list oldmap)))))
+ ;; Always return the value.
+ value)
+
+(cl-defmethod map-put! ((map hash-table) key value &optional _testfn)
+ (puthash key value map))
+
+(cl-defmethod map-put! ((map array) key value &optional _testfn)
+ ;; FIXME: If `key' is too large, should we signal `map-not-inplace'
+ ;; and let `map-insert' grow the array?
+ (aset map key value))
+
+;; 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
+;; expansion of `setf' may call this function.
+(define-obsolete-function-alias 'map--put #'map-put! "27.1")
(cl-defgeneric map-insert (map key value)
"Return a new map like MAP except that it associates KEY with VALUE.
@@ -493,11 +540,6 @@ The default implementation defaults to `map-copy' and
`map-put!'."
(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
-;; expansion of `setf' may call this function.
-(define-obsolete-function-alias 'map--put #'map-put! "27.1")
-
(cl-defmethod map-apply (function (map list))
(if (map--plist-p map)
(cl-call-next-method)
diff --git a/lisp/files-x.el b/lisp/files-x.el
index 3516592fc3..7199db3e44 100644
--- a/lisp/files-x.el
+++ b/lisp/files-x.el
@@ -635,13 +635,10 @@ of `with-connection-local-variables'.")
(defsubst connection-local-normalize-criteria (criteria)
"Normalize plist CRITERIA according to properties.
Return a reordered plist."
- (apply
- #'append
- (mapcar
- (lambda (property)
- (when (and (plist-member criteria property) (plist-get criteria
property))
- (list property (plist-get criteria property))))
- '(:application :protocol :user :machine))))
+ (mapcan (lambda (property)
+ (let ((value (plist-get criteria property)))
+ (and value (list property value))))
+ '(:application :protocol :user :machine)))
(defsubst connection-local-get-profiles (criteria)
"Return the connection profiles list for CRITERIA.
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index 40cb25fca2..0283b04574 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -106,44 +106,40 @@
;; Split the string just in case.
(version<= "3" (car (split-string bbdb-version)))))
-(defun eudc-plist-member (plist prop)
- "Return t if PROP has a value specified in PLIST."
- (if (not (= 0 (% (length plist) 2)))
+(defun eudc--plist-member (plist prop &optional predicate)
+ "Like `plist-member', but signal on invalid PLIST."
+ ;; Could also use `plistp', but that would change the error.
+ (or (zerop (% (length plist) 2))
(error "Malformed plist"))
- (catch 'found
- (while plist
- (if (eq prop (car plist))
- (throw 'found t))
- (setq plist (cdr (cdr plist))))
- nil))
+ (plist-member plist prop predicate))
-;; Emacs's plist-get lacks third parameter
+(defun eudc-plist-member (plist prop)
+ "Return t if PROP has a value specified in PLIST.
+Signal an error if PLIST is not a valid property list."
+ (and (eudc--plist-member plist prop) t))
+
+;; Emacs's `plist-get' lacks a default parameter, and CL-Lib's
+;; `cl-getf' doesn't accept a predicate or signal an error.
(defun eudc-plist-get (plist prop &optional default)
- "Extract a value from a property list.
-PLIST is a property list, which is a list of the form
-\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
-corresponding to the given PROP, or DEFAULT if PROP is not
-one of the properties on the list."
- (if (eudc-plist-member plist prop)
- (plist-get plist prop)
- default))
+ "Extract the value of PROP in property list PLIST.
+PLIST is a list of the form (PROP1 VALUE1 PROP2 VALUE2...).
+This function returns the first value corresponding to the given
+PROP, or DEFAULT if PROP is not one of the properties in the
+list. The comparison with PROP is done using `eq'. If PLIST is
+not a valid property list, this function signals an error."
+ (let ((tail (eudc--plist-member plist prop)))
+ (if tail (cadr tail) default)))
(defun eudc-lax-plist-get (plist prop &optional default)
- "Extract a value from a lax property list.
-
-PLIST is a lax property list, which is a list of the form (PROP1
-VALUE1 PROP2 VALUE2...), where comparisons between properties are done
-using `equal' instead of `eq'. This function returns the value
-corresponding to PROP, or DEFAULT if PROP is not one of the
-properties on the list."
- (if (not (= 0 (% (length plist) 2)))
- (error "Malformed plist"))
- (catch 'found
- (while plist
- (if (equal prop (car plist))
- (throw 'found (car (cdr plist))))
- (setq plist (cdr (cdr plist))))
- default))
+ "Extract the value of PROP from lax property list PLIST.
+PLIST is a list of the form (PROP1 VALUE1 PROP2 VALUE2...), where
+comparisons between properties are done using `equal' instead of
+`eq'. This function returns the first value corresponding to
+PROP, or DEFAULT if PROP is not one of the properties in the
+list. If PLIST is not a valid property list, this function
+signals an error."
+ (let ((tail (eudc--plist-member plist prop #'equal)))
+ (if tail (cadr tail) default)))
(defun eudc-replace-in-string (str regexp newtext)
"Replace all matches in STR for REGEXP with NEWTEXT.
diff --git a/src/fns.c b/src/fns.c
index 4055792382..940fb680fc 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2473,15 +2473,15 @@ with PROP is done using PREDICATE, which defaults to
`eq'.
This function doesn't signal an error if PLIST is invalid. */)
(Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate)
{
- Lisp_Object tail = plist;
if (NILP (predicate))
return plist_get (plist, prop);
+ Lisp_Object tail = plist;
FOR_EACH_TAIL_SAFE (tail)
{
if (! CONSP (XCDR (tail)))
break;
- if (!NILP (call2 (predicate, prop, XCAR (tail))))
+ if (!NILP (call2 (predicate, XCAR (tail), prop)))
return XCAR (XCDR (tail));
tail = XCDR (tail);
}
@@ -2489,7 +2489,7 @@ This function doesn't signal an error if PLIST is
invalid. */)
return Qnil;
}
-/* Faster version of the above that works with EQ only */
+/* Faster version of Fplist_get that works with EQ only. */
Lisp_Object
plist_get (Lisp_Object plist, Lisp_Object prop)
{
@@ -2498,7 +2498,7 @@ plist_get (Lisp_Object plist, Lisp_Object prop)
{
if (! CONSP (XCDR (tail)))
break;
- if (EQ (prop, XCAR (tail)))
+ if (EQ (XCAR (tail), prop))
return XCAR (XCDR (tail));
tail = XCDR (tail);
}
@@ -2532,15 +2532,15 @@ use `(setq x (plist-put x prop val))' to be sure to use
the new value.
The PLIST is modified by side effects. */)
(Lisp_Object plist, Lisp_Object prop, Lisp_Object val, Lisp_Object predicate)
{
- Lisp_Object prev = Qnil, tail = plist;
if (NILP (predicate))
return plist_put (plist, prop, val);
+ Lisp_Object prev = Qnil, tail = plist;
FOR_EACH_TAIL (tail)
{
if (! CONSP (XCDR (tail)))
break;
- if (!NILP (call2 (predicate, prop, XCAR (tail))))
+ if (!NILP (call2 (predicate, XCAR (tail), prop)))
{
Fsetcar (XCDR (tail), val);
return plist;
@@ -2558,6 +2558,7 @@ The PLIST is modified by side effects. */)
return plist;
}
+/* Faster version of Fplist_put that works with EQ only. */
Lisp_Object
plist_put (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
{
@@ -2567,7 +2568,7 @@ plist_put (Lisp_Object plist, Lisp_Object prop,
Lisp_Object val)
if (! CONSP (XCDR (tail)))
break;
- if (EQ (prop, XCAR (tail)))
+ if (EQ (XCAR (tail), prop))
{
Fsetcar (XCDR (tail), val);
return plist;
@@ -2595,6 +2596,51 @@ It can be retrieved with `(get SYMBOL PROPNAME)'. */)
(symbol, plist_put (XSYMBOL (symbol)->u.s.plist, propname, value));
return value;
}
+
+DEFUN ("plist-member", Fplist_member, Splist_member, 2, 3, 0,
+ doc: /* Return non-nil if PLIST has the property PROP.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2 ...).
+
+The comparison with PROP is done using PREDICATE, which defaults to
+`eq'.
+
+Unlike `plist-get', this allows you to distinguish between a missing
+property and a property with the value nil.
+The value is actually the tail of PLIST whose car is PROP. */)
+ (Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate)
+{
+ if (NILP (predicate))
+ return plist_member (plist, prop);
+ Lisp_Object tail = plist;
+ FOR_EACH_TAIL (tail)
+ {
+ if (!NILP (call2 (predicate, XCAR (tail), prop)))
+ return tail;
+ tail = XCDR (tail);
+ if (! CONSP (tail))
+ break;
+ }
+ CHECK_TYPE (NILP (tail), Qplistp, plist);
+ return Qnil;
+}
+
+/* Faster version of Fplist_member that works with EQ only. */
+Lisp_Object
+plist_member (Lisp_Object plist, Lisp_Object prop)
+{
+ Lisp_Object tail = plist;
+ FOR_EACH_TAIL (tail)
+ {
+ if (EQ (XCAR (tail), prop))
+ return tail;
+ tail = XCDR (tail);
+ if (! CONSP (tail))
+ break;
+ }
+ CHECK_TYPE (NILP (tail), Qplistp, plist);
+ return Qnil;
+}
DEFUN ("eql", Feql, Seql, 2, 2, 0,
doc: /* Return t if the two args are `eq' or are indistinguishable
numbers.
@@ -3388,43 +3434,6 @@ FILENAME are suppressed. */)
bottleneck of Widget operation. Here is their translation to C,
for the sole reason of efficiency. */
-DEFUN ("plist-member", Fplist_member, Splist_member, 2, 3, 0,
- doc: /* Return non-nil if PLIST has the property PROP.
-PLIST is a property list, which is a list of the form
-\(PROP1 VALUE1 PROP2 VALUE2 ...).
-
-The comparison with PROP is done using PREDICATE, which defaults to
-`eq'.
-
-Unlike `plist-get', this allows you to distinguish between a missing
-property and a property with the value nil.
-The value is actually the tail of PLIST whose car is PROP. */)
- (Lisp_Object plist, Lisp_Object prop, Lisp_Object predicate)
-{
- Lisp_Object tail = plist;
- if (NILP (predicate))
- predicate = Qeq;
- FOR_EACH_TAIL (tail)
- {
- if (!NILP (call2 (predicate, XCAR (tail), prop)))
- return tail;
- tail = XCDR (tail);
- if (! CONSP (tail))
- break;
- }
- CHECK_TYPE (NILP (tail), Qplistp, plist);
- return Qnil;
-}
-
-/* plist_member isn't used much in the Emacs sources, so just provide
- a shim so that the function name follows the same pattern as
- plist_get/plist_put. */
-Lisp_Object
-plist_member (Lisp_Object plist, Lisp_Object prop)
-{
- return Fplist_member (plist, prop, Qnil);
-}
-
DEFUN ("widget-put", Fwidget_put, Swidget_put, 3, 3, 0,
doc: /* In WIDGET, set PROPERTY to VALUE.
The value can later be retrieved with `widget-get'. */)
diff --git a/test/lisp/apropos-tests.el b/test/lisp/apropos-tests.el
index 289700abf7..917c08b911 100644
--- a/test/lisp/apropos-tests.el
+++ b/test/lisp/apropos-tests.el
@@ -120,14 +120,15 @@
(should (apropos-true-hit "foo bar baz" '("foo" "bar"))))
(ert-deftest apropos-tests-format-plist ()
- (setplist 'foo '(a 1 b (2 3) c nil))
- (apropos-parse-pattern '("b"))
- (should (equal (apropos-format-plist 'foo ", ")
- "a 1, b (2 3), c nil"))
- (should (equal (apropos-format-plist 'foo ", " t)
- "b (2 3)"))
- (apropos-parse-pattern '("d"))
- (should-not (apropos-format-plist 'foo ", " t)))
+ (let ((foo (make-symbol "foo")))
+ (setplist foo '(a 1 b (2 3) c nil))
+ (apropos-parse-pattern '("b"))
+ (should (equal (apropos-format-plist foo ", ")
+ "a 1, b (2 3), c nil"))
+ (should (equal (apropos-format-plist foo ", " t)
+ "b (2 3)"))
+ (apropos-parse-pattern '("d"))
+ (should-not (apropos-format-plist foo ", " t))))
(provide 'apropos-tests)
;;; apropos-tests.el ends here
diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el
b/test/lisp/emacs-lisp/cl-extra-tests.el
index 297e413d85..6a34cd681e 100644
--- a/test/lisp/emacs-lisp/cl-extra-tests.el
+++ b/test/lisp/emacs-lisp/cl-extra-tests.el
@@ -32,8 +32,28 @@
(ert-deftest cl-getf ()
(let ((plist '(x 1 y nil)))
(should (eq (cl-getf plist 'x) 1))
- (should (eq (cl-getf plist 'y :none) nil))
- (should (eq (cl-getf plist 'z :none) :none))))
+ (should-not (cl-getf plist 'y :none))
+ (should (eq (cl-getf plist 'z :none) :none))
+ (should (eq (cl-incf (cl-getf plist 'x 10) 2) 3))
+ (should (equal plist '(x 3 y nil)))
+ (should-error (cl-incf (cl-getf plist 'y 10) 4) :type 'wrong-type-argument)
+ (should (equal plist '(x 3 y nil)))
+ (should (eq (cl-incf (cl-getf plist 'z 10) 5) 15))
+ (should (equal plist '(z 15 x 3 y nil))))
+ (let ((plist '(x 1 y)))
+ (should (eq (cl-getf plist 'x) 1))
+ (should (eq (cl-getf plist 'y :none) :none))
+ (should (eq (cl-getf plist 'z :none) :none))
+ (should (eq (cl-incf (cl-getf plist 'x 10) 2) 3))
+ (should (equal plist '(x 3 y)))
+ (should (eq (cl-incf (cl-getf plist 'y 10) 4) 14))
+ (should (equal plist '(y 14 x 3 y))))
+ (let ((plist '(x 1 y . 2)))
+ (should (eq (cl-getf plist 'x) 1))
+ (should (eq (cl-incf (cl-getf plist 'x 10) 2) 3))
+ (should (equal plist '(x 3 y . 2)))
+ (should-error (cl-getf plist 'y :none) :type 'wrong-type-argument)
+ (should-error (cl-getf plist 'z :none) :type 'wrong-type-argument)))
(ert-deftest cl-extra-test-mapc ()
(let ((lst '(a b c))
diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el
index 0757e3c7aa..69a7bcf7dd 100644
--- a/test/lisp/emacs-lisp/gv-tests.el
+++ b/test/lisp/emacs-lisp/gv-tests.el
@@ -157,55 +157,42 @@ its getter (Bug#41853)."
(push 123 (gv-setter-edebug-get 'gv-setter-edebug
'gv-setter-edebug-prop))))
(print form (current-buffer)))
- ;; Only check whether evaluation works in general.
- (eval-buffer)))
+ ;; Silence "Edebug: foo" messages.
+ (let ((inhibit-message t))
+ ;; Only check whether evaluation works in general.
+ (eval-buffer))))
(should (equal (get 'gv-setter-edebug 'gv-setter-edebug-prop) '(123))))
(ert-deftest gv-plist-get ()
- (require 'cl-lib)
-
- ;; Simple setf usage for plist-get.
- (should (equal (let ((target '(:a "a" :b "b" :c "c")))
- (setf (plist-get target :b) "modify")
- target)
- '(:a "a" :b "modify" :c "c")))
-
- ;; Other function (cl-rotatef) usage for plist-get.
- (should (equal (let ((target '(:a "a" :b "b" :c "c")))
- (cl-rotatef (plist-get target :b) (plist-get target :c))
- target)
- '(:a "a" :b "c" :c "b")))
-
- ;; Add new key value pair at top of list if setf for missing key.
- (should (equal (let ((target '(:a "a" :b "b" :c "c")))
- (setf (plist-get target :d) "modify")
- target)
- '(:d "modify" :a "a" :b "b" :c "c")))
+ ;; Simple `setf' usage for `plist-get'.
+ (let ((target (list :a "a" :b "b" :c "c")))
+ (setf (plist-get target :b) "modify")
+ (should (equal target '(:a "a" :b "modify" :c "c")))
+ (setf (plist-get target ":a" #'string=) "mogrify")
+ (should (equal target '(:a "mogrify" :b "modify" :c "c"))))
+
+ ;; Other function (`cl-rotatef') usage for `plist-get'.
+ (let ((target (list :a "a" :b "b" :c "c")))
+ (cl-rotatef (plist-get target :b) (plist-get target :c))
+ (should (equal target '(:a "a" :b "c" :c "b")))
+ (cl-rotatef (plist-get target ":a" #'string=)
+ (plist-get target ":b" #'string=))
+ (should (equal target '(:a "c" :b "a" :c "b"))))
+
+ ;; Add new key value pair at top of list if `setf' for missing key.
+ (let ((target (list :a "a" :b "b" :c "c")))
+ (setf (plist-get target :d) "modify")
+ (should (equal target '(:d "modify" :a "a" :b "b" :c "c")))
+ (setf (plist-get target :e #'string=) "mogrify")
+ (should (equal target '(:e "mogrify" :d "modify" :a "a" :b "b" :c "c"))))
;; Rotate with missing value.
;; The value corresponding to the missing key is assumed to be nil.
- (should (equal (let ((target '(:a "a" :b "b" :c "c")))
- (cl-rotatef (plist-get target :b) (plist-get target :d))
- target)
- '(:d "b" :a "a" :b nil :c "c")))
-
- ;; Simple setf usage for plist-get. (symbol plist)
- (should (equal (let ((target '(a "a" b "b" c "c")))
- (setf (plist-get target 'b) "modify")
- target)
- '(a "a" b "modify" c "c")))
-
- ;; Other function (cl-rotatef) usage for plist-get. (symbol plist)
- (should (equal (let ((target '(a "a" b "b" c "c")))
- (cl-rotatef (plist-get target 'b) (plist-get target 'c))
- target)
- '(a "a" b "c" c "b"))))
-
-;; `ert-deftest' messes up macroexpansion when the test file itself is
-;; compiled (see Bug #24402).
-
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+ (let ((target (list :a "a" :b "b" :c "c")))
+ (cl-rotatef (plist-get target :b) (plist-get target :d))
+ (should (equal target '(:d "b" :a "a" :b nil :c "c")))
+ (cl-rotatef (plist-get target ":e" #'string=)
+ (plist-get target ":d" #'string=))
+ (should (equal target '(":e" "b" :d nil :a "a" :b nil :c "c")))))
;;; gv-tests.el ends here
diff --git a/test/lisp/emacs-lisp/map-tests.el
b/test/lisp/emacs-lisp/map-tests.el
index 314a1c9e30..75ebe59431 100644
--- a/test/lisp/emacs-lisp/map-tests.el
+++ b/test/lisp/emacs-lisp/map-tests.el
@@ -29,10 +29,13 @@
(require 'ert)
(require 'map)
+(eval-when-compile
+ (require 'cl-lib))
+
(defmacro with-maps-do (var &rest body)
"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)).
+ ((0 . 3) (1 . 4) (2 . 5))
Evaluate BODY for each created map."
(declare (indent 1) (debug (symbolp body)))
(let ((alist (make-symbol "alist"))
@@ -84,18 +87,96 @@ Evaluate BODY for each created map."
(with-empty-maps-do map
(should (= 5 (map-elt map 0 5)))))
-(ert-deftest test-map-elt-testfn ()
+(ert-deftest test-map-elt-testfn-alist ()
+ "Test the default alist predicate of `map-elt'."
(let* ((a (string ?a))
(map `((,a . 0) (,(string ?b) . 1))))
- (should (= (map-elt map a) 0))
- (should (= (map-elt map "a") 0))
- (should (= (map-elt map (string ?a)) 0))
- (should (= (map-elt map "b") 1))
- (should (= (map-elt map (string ?b)) 1))))
+ (should (= 0 (map-elt map a)))
+ (should (= 0 (map-elt map "a")))
+ (should (= 0 (map-elt map (string ?a))))
+ (should (= 1 (map-elt map "b")))
+ (should (= 1 (map-elt map (string ?b))))
+ (with-suppressed-warnings ((callargs map-elt))
+ (should (= 0 (map-elt map 'a nil #'string=)))
+ (should (= 1 (map-elt map 'b nil #'string=))))))
+
+(ert-deftest test-map-elt-testfn-plist ()
+ "Test the default plist predicate of `map-elt'."
+ (let* ((a (string ?a))
+ (map `(,a 0 "b" 1)))
+ (should-not (map-elt map "a"))
+ (should-not (map-elt map "b"))
+ (should-not (map-elt map (string ?a)))
+ (should-not (map-elt map (string ?b)))
+ (should (= 0 (map-elt map a)))
+ (with-suppressed-warnings ((callargs map-elt))
+ (should (= 0 (map-elt map a nil #'equal)))
+ (should (= 0 (map-elt map "a" nil #'equal)))
+ (should (= 0 (map-elt map (string ?a) nil #'equal)))
+ (should (= 1 (map-elt map "b" nil #'equal)))
+ (should (= 1 (map-elt map (string ?b) nil #'equal))))))
+
+(ert-deftest test-map-elt-gv ()
+ "Test the generalized variable `map-elt'."
+ (let ((sort (lambda (map) (sort (map-pairs map) #'car-less-than-car))))
+ (with-empty-maps-do map
+ ;; Empty map, without default.
+ (should-error (cl-incf (map-elt map 1)) :type 'wrong-type-argument)
+ (with-suppressed-warnings ((callargs map-elt))
+ (should-error (cl-incf (map-elt map 1.0 nil #'=))
+ :type 'wrong-type-argument))
+ (should (map-empty-p map))
+ ;; Empty map, with default.
+ (if (vectorp map)
+ (progn
+ (should-error (cl-incf (map-elt map 1 3)) :type 'args-out-of-range)
+ (with-suppressed-warnings ((callargs map-elt))
+ (should-error (cl-incf (map-elt map 1 3 #'=))
+ :type 'args-out-of-range))
+ (should (map-empty-p map)))
+ (should (= (cl-incf (map-elt map 1 3) 10) 13))
+ (with-suppressed-warnings ((callargs map-elt))
+ (should (= (cl-incf (map-elt map 2.0 5 #'=) 12) 17)))
+ (should (equal (funcall sort map) '((1 . 13) (2.0 . 17))))))
+ (with-maps-do map
+ ;; Nonempty map, without predicate.
+ (should (= (cl-incf (map-elt map 1 3) 10) 14))
+ (should (equal (funcall sort map) '((0 . 3) (1 . 14) (2 . 5))))
+ ;; Nonempty map, with predicate.
+ (with-suppressed-warnings ((callargs map-elt))
+ (pcase-exhaustive map
+ ((pred consp)
+ (should (= (cl-incf (map-elt map 2.0 6 #'=) 12) 17))
+ (should (equal (funcall sort map) '((0 . 3) (1 . 14) (2 . 17))))
+ (should (= (cl-incf (map-elt map 0 7 #'=) 13) 16))
+ (should (equal (funcall sort map) '((0 . 16) (1 . 14) (2 . 17)))))
+ ((pred vectorp)
+ (should-error (cl-incf (map-elt map 2.0 6 #'=))
+ :type 'wrong-type-argument)
+ (should (equal (funcall sort map) '((0 . 3) (1 . 14) (2 . 5))))
+ (should (= (cl-incf (map-elt map 2 6 #'=) 12) 17))
+ (should (equal (funcall sort map) '((0 . 3) (1 . 14) (2 . 17))))
+ (should (= (cl-incf (map-elt map 0 7 #'=) 13) 16))
+ (should (equal (funcall sort map) '((0 . 16) (1 . 14) (2 . 17)))))
+ ((pred hash-table-p)
+ (should (= (cl-incf (map-elt map 2.0 6 #'=) 12) 18))
+ (should (member (funcall sort map)
+ '(((0 . 3) (1 . 14) (2 . 5) (2.0 . 18))
+ ((0 . 3) (1 . 14) (2.0 . 18) (2 . 5)))))
+ (should (= (cl-incf (map-elt map 0 7 #'=) 13) 16))
+ (should (member (funcall sort map)
+ '(((0 . 16) (1 . 14) (2 . 5) (2.0 . 18))
+ ((0 . 16) (1 . 14) (2.0 . 18) (2 . 5)))))))))))
(ert-deftest test-map-elt-with-nil-value ()
(should-not (map-elt '((a . 1) (b)) 'b 2)))
+(ert-deftest test-map-elt-signature ()
+ "Test that `map-elt' has the right advertised signature.
+See bug#58531#25 and bug#58563."
+ (should (equal (get-advertised-calling-convention (symbol-function 'map-elt))
+ '(map key &optional default))))
+
(ert-deftest test-map-put! ()
(with-maps-do map
(setf (map-elt map 2) 'hello)
@@ -144,6 +225,24 @@ Evaluate BODY for each created map."
(should (equal map '(("a" . 1))))
(should-error (map-put! map (string ?a) val #'eq) :type 'map-not-inplace)))
+(ert-deftest test-map-put!-plist ()
+ "Test `map-put!' predicate on plists."
+ (let* ((a (string ?a))
+ (map (list a 0)))
+ (map-put! map a -1)
+ (should (equal map '("a" -1)))
+ (map-put! map 'a 2)
+ (should (equal map '("a" -1 a 2)))
+ (with-suppressed-warnings ((callargs map-put!))
+ (map-put! map 'a -3 #'string=))
+ (should (equal map '("a" -3 a 2)))))
+
+(ert-deftest test-map-put!-signature ()
+ "Test that `map-put!' has the right advertised signature.
+See bug#58531#25 and bug#58563."
+ (should (equal (get-advertised-calling-convention (symbol-function
'map-put!))
+ '(map key value))))
+
(ert-deftest test-map-put-alist-new-key ()
"Regression test for Bug#23105."
(let ((alist (list (cons 0 'a))))
@@ -395,13 +494,23 @@ Evaluate BODY for each created map."
(alist '(("a" . 1) (a . 2))))
(should (map-contains-key alist 'a))
(should (map-contains-key plist 'a))
+ ;; FIXME: Why is no warning emitted for these (bug#58563#13)?
(should (map-contains-key alist 'a #'eq))
(should (map-contains-key plist 'a #'eq))
(should (map-contains-key alist key))
+ (should (map-contains-key alist "a"))
+ (should (map-contains-key plist (string ?a) #'equal))
(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-contains-key-signature ()
+ "Test that `map-contains-key' has the right advertised signature.
+See bug#58531#25 and bug#58563."
+ (should (equal (get-advertised-calling-convention
+ (symbol-function 'map-contains-key))
+ '(map key))))
+
(ert-deftest test-map-some ()
(with-maps-do map
(should (eq (map-some (lambda (k _v) (and (= k 1) 'found)) map)
@@ -515,19 +624,19 @@ Evaluate BODY for each created map."
(should (equal alist '((key . value))))))
(ert-deftest test-map-setf-alist-overwrite-key ()
- (let ((alist '((key . value1))))
+ (let ((alist (list (cons 'key 'value1))))
(should (equal (setf (map-elt alist 'key) 'value2)
'value2))
(should (equal alist '((key . value2))))))
(ert-deftest test-map-setf-plist-insert-key ()
- (let ((plist '(key value)))
+ (let ((plist (list 'key 'value)))
(should (equal (setf (map-elt plist 'key2) 'value2)
'value2))
(should (equal plist '(key value key2 value2)))))
(ert-deftest test-map-setf-plist-overwrite-key ()
- (let ((plist '(key value)))
+ (let ((plist (list 'key 'value)))
(should (equal (setf (map-elt plist 'key) 'value2)
'value2))
(should (equal plist '(key value2)))))
@@ -535,14 +644,14 @@ Evaluate BODY for each created map."
(ert-deftest test-hash-table-setf-insert-key ()
(let ((ht (make-hash-table)))
(should (equal (setf (map-elt ht 'key) 'value)
- 'value))
+ 'value))
(should (equal (map-elt ht 'key) 'value))))
(ert-deftest test-hash-table-setf-overwrite-key ()
(let ((ht (make-hash-table)))
(puthash 'key 'value1 ht)
(should (equal (setf (map-elt ht 'key) 'value2)
- 'value2))
+ 'value2))
(should (equal (map-elt ht 'key) 'value2))))
(ert-deftest test-setf-map-with-function ()
@@ -551,8 +660,79 @@ Evaluate BODY for each created map."
(setf (map-elt map 'foo)
(funcall (lambda ()
(cl-incf num))))
+ (should (equal map '((foo . 1))))
;; Check that the function is only called once.
(should (= num 1))))
+(ert-deftest test-map-plist-member ()
+ "Test `map--plist-member' and `map--plist-member-1'."
+ (dolist (mem '(map--plist-member map--plist-member-1))
+ ;; Lambda exercises Lisp implementation.
+ (dolist (= `(nil ,(lambda (a b) (eq a b))))
+ (should-not (funcall mem () 'a =))
+ (should-not (funcall mem '(a) 'b =))
+ (should-not (funcall mem '(a 1) 'b =))
+ (should (equal (funcall mem '(a) 'a =) '(a)))
+ (should (equal (funcall mem '(a . 1) 'a =) '(a . 1)))
+ (should (equal (funcall mem '(a 1 . b) 'a =) '(a 1 . b)))
+ (should (equal (funcall mem '(a 1 b) 'a =) '(a 1 b)))
+ (should (equal (funcall mem '(a 1 b) 'b =) '(b)))
+ (should (equal (funcall mem '(a 1 b . 2) 'a =) '(a 1 b . 2)))
+ (should (equal (funcall mem '(a 1 b . 2) 'b =) '(b . 2)))
+ (should (equal (funcall mem '(a 1 b 2) 'a =) '(a 1 b 2)))
+ (should (equal (funcall mem '(a 1 b 2) 'b =) '(b 2)))
+ (should (equal (should-error (funcall mem '(a . 1) 'b =))
+ '(wrong-type-argument plistp (a . 1))))
+ (should (equal (should-error (funcall mem '(a 1 . b) 'b =))
+ '(wrong-type-argument plistp (a 1 . b)))))
+ (should (equal (funcall mem '(a 1 b 2) "a" #'string=) '(a 1 b 2)))
+ (should (equal (funcall mem '(a 1 b 2) "b" #'string=) '(b 2)))))
+
+(ert-deftest test-map-plist-put ()
+ "Test `map--plist-put' and `map--plist-put-1'."
+ (dolist (put '(map--plist-put map--plist-put-1))
+ ;; Lambda exercises Lisp implementation.
+ (dolist (= `(nil ,(lambda (a b) (eq a b))))
+ (let ((l ()))
+ (should (equal (funcall put l 'a 1 =) '(a 1)))
+ (should-not l))
+ (let ((l (list 'a)))
+ (dolist (key '(a b))
+ (should (equal (should-error (funcall put l key 1 =))
+ '(wrong-type-argument plistp (a)))))
+ (should (equal l '(a))))
+ (let ((l (cons 'a 1)))
+ (dolist (key '(a b))
+ (should (equal (should-error (funcall put l key 1 =))
+ '(wrong-type-argument plistp (a . 1)))))
+ (should (equal l '(a . 1))))
+ (let ((l (cons 'a (cons 1 'b))))
+ (should (equal (funcall put l 'a 2 =) '(a 2 . b)))
+ (dolist (key '(b c))
+ (should (equal (should-error (funcall put l key 3 =))
+ '(wrong-type-argument plistp (a 2 . b)))))
+ (should (equal l '(a 2 . b))))
+ (let ((l (list 'a 1 'b)))
+ (should (equal (funcall put l 'a 2 =) '(a 2 b)))
+ (dolist (key '(b c))
+ (should (equal (should-error (funcall put l key 3 =))
+ '(wrong-type-argument plistp (a 2 b)))))
+ (should (equal l '(a 2 b))))
+ (let ((l (cons 'a (cons 1 (cons 'b 2)))))
+ (should (equal (funcall put l 'a 3 =) '(a 3 b . 2)))
+ (dolist (key '(b c))
+ (should (equal (should-error (funcall put l key 4 =))
+ '(wrong-type-argument plistp (a 3 b . 2)))))
+ (should (equal l '(a 3 b . 2))))
+ (let ((l (list 'a 1 'b 2)))
+ (should (equal (funcall put l 'a 3 =) '(a 3 b 2)))
+ (should (equal (funcall put l 'b 4 =) '(a 3 b 4)))
+ (should (equal (funcall put l 'c 5 =) '(a 3 b 4 c 5)))
+ (should (equal l '(a 3 b 4 c 5)))))
+ (let ((l (list 'a 1 'b 2)))
+ (should (equal (funcall put l "a" 3 #'string=) '(a 3 b 2)))
+ (should (equal (funcall put l "b" 4 #'string=) '(a 3 b 4)))
+ (should (equal (funcall put l "c" 5 #'string=) '(a 3 b 4 "c" 5))))))
+
(provide 'map-tests)
;;; map-tests.el ends here
diff --git a/test/lisp/net/eudc-tests.el b/test/lisp/net/eudc-tests.el
new file mode 100644
index 0000000000..219c250bf0
--- /dev/null
+++ b/test/lisp/net/eudc-tests.el
@@ -0,0 +1,155 @@
+;;; eudc-tests.el --- tests for eudc.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2022 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'eudc)
+
+(ert-deftest eudc--plist-member ()
+ "Test `eudc--plist-member' behavior."
+ (dolist (obj '(a (a . a) (a a . a)))
+ (should-error (eudc--plist-member obj nil) :type 'wrong-type-argument))
+ (dolist (plist '((nil) (a) (a a a)))
+ (dolist (key '(nil a))
+ (should (equal (should-error (eudc--plist-member plist key))
+ '(error "Malformed plist")))))
+ (let ((-nil (string ?n ?i ?l))
+ (-a (string ?a)))
+ (should-not (eudc--plist-member () nil))
+ (should-not (eudc--plist-member () 'a))
+ (should-not (eudc--plist-member '(nil nil) 'a))
+ (should-not (eudc--plist-member '(nil a) 'a))
+ (should-not (eudc--plist-member '(a nil) nil))
+ (should-not (eudc--plist-member '(a a) nil))
+ (should-not (eudc--plist-member '("nil" a) nil))
+ (should-not (eudc--plist-member '("nil" a) -nil))
+ (should-not (eudc--plist-member '("a" a) nil))
+ (should-not (eudc--plist-member '("a" a) -a))
+ (should-not (eudc--plist-member '(nil a nil a) 'a))
+ (should-not (eudc--plist-member '(nil a "a" a) -a))
+ (should (equal (eudc--plist-member '(nil nil) nil) '(nil nil)))
+ (should (equal (eudc--plist-member '(nil a) nil) '(nil a)))
+ (should (equal (eudc--plist-member '(a nil) 'a) '(a nil)))
+ (should (equal (eudc--plist-member '(a a) 'a) '(a a)))
+ (should (equal (eudc--plist-member '(nil nil a nil) 'a) '(a nil)))
+ (should (equal (eudc--plist-member '(nil a a a) 'a) '(a a)))
+ (should (equal (eudc--plist-member '(a a a a) 'a) '(a a a a)))))
+
+(ert-deftest eudc-plist-member ()
+ "Test `eudc-plist-member' behavior."
+ (dolist (obj '(a (a . a) (a a . a)))
+ (should-error (eudc-plist-member obj nil) :type 'wrong-type-argument))
+ (dolist (plist '((nil) (a) (a a a)))
+ (dolist (key '(nil a))
+ (should (equal (should-error (eudc-plist-member plist key))
+ '(error "Malformed plist")))))
+ (let ((-nil (string ?n ?i ?l))
+ (-a (string ?a)))
+ (should-not (eudc-plist-member () nil))
+ (should-not (eudc-plist-member () 'a))
+ (should-not (eudc-plist-member '(nil nil) 'a))
+ (should-not (eudc-plist-member '(nil a) 'a))
+ (should-not (eudc-plist-member '(a nil) nil))
+ (should-not (eudc-plist-member '(a a) nil))
+ (should-not (eudc-plist-member '("nil" a) nil))
+ (should-not (eudc-plist-member '("nil" a) -nil))
+ (should-not (eudc-plist-member '("a" a) nil))
+ (should-not (eudc-plist-member '("a" a) -a))
+ (should-not (eudc-plist-member '(nil a nil a) 'a))
+ (should-not (eudc-plist-member '(nil a "a" a) -a))
+ (should (eq t (eudc-plist-member '(nil nil) nil)))
+ (should (eq t (eudc-plist-member '(nil a) nil)))
+ (should (eq t (eudc-plist-member '(a nil) 'a)))
+ (should (eq t (eudc-plist-member '(a a) 'a)))
+ (should (eq t (eudc-plist-member '(nil nil a nil) 'a)))
+ (should (eq t (eudc-plist-member '(nil a a a) 'a)))
+ (should (eq t (eudc-plist-member '(a a a a) 'a)))))
+
+(ert-deftest eudc-plist-get ()
+ "Test `eudc-plist-get' behavior."
+ (dolist (obj '(a (a . a) (a a . a)))
+ (should-error (eudc-plist-get obj nil) :type 'wrong-type-argument))
+ (dolist (plist '((nil) (a) (a a a)))
+ (dolist (key '(nil a))
+ (should (equal (should-error (eudc-plist-get plist key))
+ '(error "Malformed plist")))))
+ (let ((-nil (string ?n ?i ?l))
+ (-a (string ?a)))
+ (should-not (eudc-plist-get () nil))
+ (should-not (eudc-plist-get () 'a))
+ (should-not (eudc-plist-get '(nil nil) nil))
+ (should-not (eudc-plist-get '(nil nil) 'a))
+ (should-not (eudc-plist-get '(nil a) 'a))
+ (should-not (eudc-plist-get '(a nil) nil))
+ (should-not (eudc-plist-get '(a nil) 'a))
+ (should-not (eudc-plist-get '(a a) nil))
+ (should-not (eudc-plist-get '("nil" a) nil))
+ (should-not (eudc-plist-get '("nil" a) -nil))
+ (should-not (eudc-plist-get '("a" a) nil))
+ (should-not (eudc-plist-get '("a" a) -a))
+ (should-not (eudc-plist-get '(nil nil nil a) nil))
+ (should-not (eudc-plist-get '(nil a nil a) 'a))
+ (should-not (eudc-plist-get '(nil a "a" a) -a))
+ (should-not (eudc-plist-get '(a nil a a) 'a))
+ (should (eq 'a (eudc-plist-get '(nil a) nil)))
+ (should (eq 'a (eudc-plist-get '(a a) 'a)))
+ (should (eq 'a (eudc-plist-get '(a a a nil) 'a)))
+ (should (eq 'b (eudc-plist-get () nil 'b)))
+ (should (eq 'b (eudc-plist-get () 'a 'b)))
+ (should (eq 'b (eudc-plist-get '(nil a "a" a) -a 'b)))
+ (should (eq 'b (eudc-plist-get '(a nil "nil" nil) -nil 'b)))))
+
+(ert-deftest eudc-lax-plist-get ()
+ "Test `eudc-lax-plist-get' behavior."
+ (dolist (obj '(a (a . a) (a a . a)))
+ (should-error (eudc-lax-plist-get obj nil) :type 'wrong-type-argument))
+ (dolist (plist '((nil) (a) (a a a)))
+ (dolist (key '(nil a))
+ (should (equal (should-error (eudc-lax-plist-get plist key))
+ '(error "Malformed plist")))))
+ (let ((-nil (string ?n ?i ?l))
+ (-a (string ?a)))
+ (should-not (eudc-lax-plist-get () nil))
+ (should-not (eudc-lax-plist-get () 'a))
+ (should-not (eudc-lax-plist-get '(nil nil) nil))
+ (should-not (eudc-lax-plist-get '(nil nil) 'a))
+ (should-not (eudc-lax-plist-get '(nil a) 'a))
+ (should-not (eudc-lax-plist-get '(a nil) nil))
+ (should-not (eudc-lax-plist-get '(a nil) 'a))
+ (should-not (eudc-lax-plist-get '(a a) nil))
+ (should-not (eudc-lax-plist-get '("nil" a) nil))
+ (should-not (eudc-lax-plist-get '("nil" a) 'a))
+ (should-not (eudc-lax-plist-get '("a" a) nil))
+ (should-not (eudc-lax-plist-get '("a" a) 'a))
+ (should-not (eudc-lax-plist-get '(nil nil nil a) nil))
+ (should-not (eudc-lax-plist-get '(nil a nil a) 'a))
+ (should-not (eudc-lax-plist-get '(nil a "a" a) 'a))
+ (should-not (eudc-lax-plist-get '(a nil a a) 'a))
+ (should (eq 'a (eudc-lax-plist-get '(nil a) nil)))
+ (should (eq 'a (eudc-lax-plist-get '(a a) 'a)))
+ (should (eq 'a (eudc-lax-plist-get '(a a a nil) 'a)))
+ (should (eq 'b (eudc-lax-plist-get () nil 'b)))
+ (should (eq 'b (eudc-lax-plist-get () 'a 'b)))
+ (should (eq 'a (eudc-lax-plist-get '("nil" a) -nil)))
+ (should (eq 'a (eudc-lax-plist-get '("a" a) -a)))
+ (should (eq 'a (eudc-lax-plist-get '(nil a "a" a) -a)))
+ (should (eq 'b (eudc-lax-plist-get '(nil a "a" a) 'a 'b)))
+ (should (eq 'b (eudc-lax-plist-get '(a nil "nil" nil) nil 'b)))))
+
+;;; eudc-tests.el ends here
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 347981e818..cc9610cd39 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -1139,7 +1139,10 @@ final or penultimate step during initialization."))
(should-not (plistp '(1 . 2)))
(should (plistp '(1 2 3 4)))
(should-not (plistp '(1 2 3)))
- (should-not (plistp '(1 2 3 . 4))))
+ (should-not (plistp '(1 2 3 . 4)))
+ (let ((cycle (list 1 2 3)))
+ (nconc cycle cycle)
+ (should-not (plistp cycle))))
(defun subr-tests--butlast-ref (list &optional n)
"Reference implementation of `butlast'."
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index fde5af38fc..7568d941d0 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -857,6 +857,14 @@
(should-error (reverse (dot1 1)) :type 'wrong-type-argument)
(should-error (reverse (dot2 1 2)) :type 'wrong-type-argument))
+(ert-deftest test-cycle-equal ()
+ (should-error (equal (cyc1 1) (cyc1 1)))
+ (should-error (equal (cyc2 1 2) (cyc2 1 2))))
+
+(ert-deftest test-cycle-nconc ()
+ (should-error (nconc (cyc1 1) 'tail) :type 'circular-list)
+ (should-error (nconc (cyc2 1 2) 'tail) :type 'circular-list))
+
(ert-deftest test-cycle-plist-get ()
(let ((c1 (cyc1 1))
(c2 (cyc2 1 2))
@@ -911,30 +919,47 @@
(should-error (plist-put d1 3 3) :type 'wrong-type-argument)
(should-error (plist-put d2 3 3) :type 'wrong-type-argument)))
-(ert-deftest test-cycle-equal ()
- (should-error (equal (cyc1 1) (cyc1 1)))
- (should-error (equal (cyc2 1 2) (cyc2 1 2))))
-
-(ert-deftest test-cycle-nconc ()
- (should-error (nconc (cyc1 1) 'tail) :type 'circular-list)
- (should-error (nconc (cyc2 1 2) 'tail) :type 'circular-list))
-
(ert-deftest plist-get/odd-number-of-elements ()
"Test that `plist-get' doesn't signal an error on degenerate plists."
(should-not (plist-get '(:foo 1 :bar) :bar)))
(ert-deftest plist-put/odd-number-of-elements ()
- "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726.";
- (should (equal (should-error (plist-put '(:foo 1 :bar) :zot 2)
- :type 'wrong-type-argument)
+ "Check for bug#27726."
+ (should (equal (should-error (plist-put (list :foo 1 :bar) :zot 2))
'(wrong-type-argument plistp (:foo 1 :bar)))))
(ert-deftest plist-member/improper-list ()
- "Check for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27726.";
- (should (equal (should-error (plist-member '(:foo 1 . :bar) :qux)
- :type 'wrong-type-argument)
+ "Check for bug#27726."
+ (should (equal (should-error (plist-member '(:foo 1 . :bar) :qux))
'(wrong-type-argument plistp (:foo 1 . :bar)))))
+(ert-deftest test-plist ()
+ (let ((plist (list :a "b")))
+ (setq plist (plist-put plist :b "c"))
+ (should (equal (plist-get plist :b) "c"))
+ (should (equal (plist-member plist :b) '(:b "c"))))
+
+ (let ((plist (list "1" "2" "a" "b")))
+ (setq plist (plist-put plist (string ?a) "c"))
+ (should (equal plist '("1" "2" "a" "b" "a" "c")))
+ (should-not (plist-get plist (string ?a)))
+ (should-not (plist-member plist (string ?a))))
+
+ (let ((plist (list "1" "2" "a" "b")))
+ (setq plist (plist-put plist (string ?a) "c" #'equal))
+ (should (equal plist '("1" "2" "a" "c")))
+ (should (equal (plist-get plist (string ?a) #'equal) "c"))
+ (should (equal (plist-member plist (string ?a) #'equal) '("a" "c"))))
+
+ (let ((plist (list :a 1 :b 2 :c 3)))
+ (setq plist (plist-put plist ":a" 4 #'string>))
+ (should (equal plist '(:a 1 :b 4 :c 3)))
+ (should (equal (plist-get plist ":b" #'string>) 3))
+ (should (equal (plist-member plist ":c" #'string<) plist))
+ (dolist (fn '(plist-get plist-member))
+ (should-not (funcall fn plist ":a" #'string<))
+ (should-not (funcall fn plist ":c" #'string>)))))
+
(ert-deftest test-string-distance ()
"Test `string-distance' behavior."
;; ASCII characters are always fine
@@ -1350,23 +1375,6 @@
(should-error (append loop '(end))
:type 'circular-list)))
-(ert-deftest test-plist ()
- (let ((plist '(:a "b")))
- (setq plist (plist-put plist :b "c"))
- (should (equal (plist-get plist :b) "c"))
- (should (equal (plist-member plist :b) '(:b "c"))))
-
- (let ((plist '("1" "2" "a" "b")))
- (setq plist (plist-put plist (copy-sequence "a") "c"))
- (should-not (equal (plist-get plist (copy-sequence "a")) "c"))
- (should-not (equal (plist-member plist (copy-sequence "a")) '("a" "c"))))
-
- (let ((plist '("1" "2" "a" "b")))
- (setq plist (plist-put plist (copy-sequence "a") "c" #'equal))
- (should (equal (plist-get plist (copy-sequence "a") #'equal) "c"))
- (should (equal (plist-member plist (copy-sequence "a") #'equal)
- '("a" "c")))))
-
(ert-deftest fns--string-to-unibyte-multibyte ()
(dolist (str (list "" "a" "abc" "a\x00\x7fz" "a\xaa\xbbz" "\x80\xdd\xff"
(apply #'unibyte-string (number-sequence 0 255))))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- master 9da2efb670: Audit some plist uses with new predicate argument,
Basil L. Contovounesios <=