summaryrefslogtreecommitdiff
path: root/test/lisp/emacs-lisp
diff options
context:
space:
mode:
authorPhilip Kaludercic <philipk@posteo.net>2022-07-31 14:27:28 +0200
committerPhilip Kaludercic <philipk@posteo.net>2022-07-31 14:27:28 +0200
commit118033294136a8fb3a14347ce190b447dd2ff2fe (patch)
tree3d036aa53a16c1283883b0955cbed77be3295310 /test/lisp/emacs-lisp
parentedd73bd0d5474b71cbd4261c6a722be8f652bb9a (diff)
parentac237334c7672377721e4d27e8ecd6b09d453568 (diff)
downloademacs-118033294136a8fb3a14347ce190b447dd2ff2fe.tar.gz
emacs-118033294136a8fb3a14347ce190b447dd2ff2fe.tar.bz2
emacs-118033294136a8fb3a14347ce190b447dd2ff2fe.zip
Merge remote-tracking branch 'origin/master' into feature/package+vc
Diffstat (limited to 'test/lisp/emacs-lisp')
-rw-r--r--test/lisp/emacs-lisp/bindat-tests.el140
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el266
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el1
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-nonvariable.el3
-rw-r--r--test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-odd.el3
-rw-r--r--test/lisp/emacs-lisp/bytecomp-tests.el135
-rw-r--r--test/lisp/emacs-lisp/cconv-tests.el1
-rw-r--r--test/lisp/emacs-lisp/cl-macs-tests.el33
-rw-r--r--test/lisp/emacs-lisp/easy-mmode-tests.el2
-rw-r--r--test/lisp/emacs-lisp/edebug-tests.el9
-rw-r--r--test/lisp/emacs-lisp/ert-tests.el8
-rw-r--r--test/lisp/emacs-lisp/find-func-tests.el7
-rw-r--r--test/lisp/emacs-lisp/icons-tests.el63
-rw-r--r--test/lisp/emacs-lisp/nadvice-tests.el17
-rw-r--r--test/lisp/emacs-lisp/oclosure-tests.el166
-rw-r--r--test/lisp/emacs-lisp/pp-resources/code-formats.erts12
-rw-r--r--test/lisp/emacs-lisp/rmc-tests.el23
-rw-r--r--test/lisp/emacs-lisp/seq-tests.el50
-rw-r--r--test/lisp/emacs-lisp/subr-x-tests.el67
-rw-r--r--test/lisp/emacs-lisp/text-property-search-tests.el25
-rw-r--r--test/lisp/emacs-lisp/vtable-tests.el42
21 files changed, 1024 insertions, 49 deletions
diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el
index 7722cf6c020..0c03c51e2ef 100644
--- a/test/lisp/emacs-lisp/bindat-tests.el
+++ b/test/lisp/emacs-lisp/bindat-tests.el
@@ -36,7 +36,7 @@
(bindat-type
(type u8)
(opcode u8)
- (length uintr 16) ;; little endian order
+ (length uint 16 'le) ;; little endian order
(id strz 8)
(data vec length)
(_ align 4)))
@@ -128,18 +128,17 @@
(r (zerop (% kind 2))))
(dotimes (_ 100)
(let* ((n (random (ash 1 bitlen)))
- (i (- n (ash 1 (1- bitlen)))))
+ (i (- n (ash 1 (1- bitlen))))
+ (stype (bindat-type sint bitlen r))
+ (utype (bindat-type if r (uintr bitlen) (uint bitlen))))
(should (equal (bindat-unpack
- (bindat-type sint bitlen r)
- (bindat-pack (bindat-type sint bitlen r) i))
+ stype
+ (bindat-pack stype i))
i))
(when (>= i 0)
- (should (equal (bindat-pack
- (bindat-type if r (uintr bitlen) (uint bitlen)) i)
- (bindat-pack (bindat-type sint bitlen r) i)))
- (should (equal (bindat-unpack
- (bindat-type if r (uintr bitlen) (uint bitlen))
- (bindat-pack (bindat-type sint bitlen r) i))
+ (should (equal (bindat-pack utype i)
+ (bindat-pack stype i)))
+ (should (equal (bindat-unpack utype (bindat-pack stype i))
i))))))))
(defconst bindat-test--LEB128
@@ -162,4 +161,125 @@
(bindat-pack bindat-test--LEB128 n))
n)))))))
+(ert-deftest bindat-test--str-strz-prealloc ()
+ (dolist (tc `(((,(bindat-type str 1) "") . "xx")
+ ((,(bindat-type str 2) "") . "xx")
+ ((,(bindat-type str 2) "a") . "ax")
+ ((,(bindat-type str 2) "ab") . "ab")
+ ((,(bindat-type str 2) "abc") . "ab")
+ ((((x str 1)) ((x . ""))) . "xx")
+ ((((x str 2)) ((x . ""))) . "xx")
+ ((((x str 2)) ((x . "a"))) . "ax")
+ ((((x str 2)) ((x . "ab"))) . "ab")
+ ((((x str 2)) ((x . "abc"))) . "ab")
+ ((,(bindat-type strz 1) "") . "\0x")
+ ((,(bindat-type strz 2) "") . "\0x")
+ ((,(bindat-type strz 2) "a") . "a\0")
+ ((,(bindat-type strz 2) "ab") . "ab")
+ ((,(bindat-type strz 2) "abc") . "ab")
+ ((((x strz 1)) ((x . ""))) . "\0x")
+ ((((x strz 2)) ((x . ""))) . "\0x")
+ ((((x strz 2)) ((x . "a"))) . "a\0")
+ ((((x strz 2)) ((x . "ab"))) . "ab")
+ ((((x strz 2)) ((x . "abc"))) . "ab")
+ ((,(bindat-type strz) "") . "\0x")
+ ((,(bindat-type strz) "a") . "a\0")))
+ (let ((prealloc (make-string 2 ?x)))
+ (apply #'bindat-pack (append (car tc) (list prealloc)))
+ (should (equal prealloc (cdr tc))))))
+
+(ert-deftest bindat-test--str-strz-multibyte ()
+ (dolist (spec (list (bindat-type str 2)
+ (bindat-type strz 2)
+ (bindat-type strz)))
+ (should (equal (bindat-pack spec (string-to-multibyte "x")) "x\0"))
+ (should (equal (bindat-pack spec (string-to-multibyte "\xff")) "\xff\0"))
+ (should-error (bindat-pack spec "💩"))
+ (should-error (bindat-pack spec "\N{U+ff}")))
+ (dolist (spec (list '((x str 2)) '((x strz 2))))
+ (should (equal (bindat-pack spec `((x . ,(string-to-multibyte "x"))))
+ "x\0"))
+ (should (equal (bindat-pack spec `((x . ,(string-to-multibyte "\xff"))))
+ "\xff\0"))
+ (should-error (bindat-pack spec '((x . "💩"))))
+ (should-error (bindat-pack spec '((x . "\N{U+ff}"))))))
+
+(let ((spec (bindat-type strz 2)))
+ (ert-deftest bindat-test--strz-fixedlen-len ()
+ (should (equal (bindat-length spec "") 2))
+ (should (equal (bindat-length spec "a") 2)))
+
+ (ert-deftest bindat-test--strz-fixedlen-len-overflow ()
+ (should (equal (bindat-length spec "ab") 2))
+ (should (equal (bindat-length spec "abc") 2)))
+
+ (ert-deftest bindat-test--strz-fixedlen-pack ()
+ (should (equal (bindat-pack spec "") "\0\0"))
+ (should (equal (bindat-pack spec "a") "a\0")))
+
+ (ert-deftest bindat-test--strz-fixedlen-pack-overflow ()
+ ;; This is not the only valid semantic, but it's the one we've
+ ;; offered historically.
+ (should (equal (bindat-pack spec "ab") "ab"))
+ (should (equal (bindat-pack spec "abc") "ab")))
+
+ (ert-deftest bindat-test--strz-fixedlen-unpack ()
+ (should (equal (bindat-unpack spec "\0\0") ""))
+ (should (equal (bindat-unpack spec "\0X") ""))
+ (should (equal (bindat-unpack spec "a\0") "a"))
+ ;; Same comment as for b-t-s-f-pack-overflow.
+ (should (equal (bindat-unpack spec "ab") "ab"))
+ ;; Missing null terminator.
+ (should-error (bindat-unpack spec ""))
+ (should-error (bindat-unpack spec "a"))))
+
+(let ((spec (bindat-type strz)))
+ (ert-deftest bindat-test--strz-varlen-len ()
+ (should (equal (bindat-length spec "") 1))
+ (should (equal (bindat-length spec "abc") 4)))
+
+ (ert-deftest bindat-test--strz-varlen-pack ()
+ (should (equal (bindat-pack spec "") "\0"))
+ (should (equal (bindat-pack spec "abc") "abc\0"))
+ ;; Null bytes in the input string break unpacking.
+ (should-error (bindat-pack spec "\0"))
+ (should-error (bindat-pack spec "\0x"))
+ (should-error (bindat-pack spec "x\0"))
+ (should-error (bindat-pack spec "x\0y")))
+
+ (ert-deftest bindat-test--strz-varlen-unpack ()
+ (should (equal (bindat-unpack spec "\0") ""))
+ (should (equal (bindat-unpack spec "abc\0") "abc"))
+ ;; Missing null terminator.
+ (should-error (bindat-unpack spec ""))
+ (should-error (bindat-unpack spec "a"))))
+
+(let ((spec '((x strz 2))))
+ (ert-deftest bindat-test--strz-legacy-fixedlen-len ()
+ (should (equal (bindat-length spec '((x . ""))) 2))
+ (should (equal (bindat-length spec '((x . "a"))) 2)))
+
+ (ert-deftest bindat-test--strz-legacy-fixedlen-len-overflow ()
+ (should (equal (bindat-length spec '((x . "ab"))) 2))
+ (should (equal (bindat-length spec '((x . "abc"))) 2)))
+
+ (ert-deftest bindat-test--strz-legacy-fixedlen-pack ()
+ (should (equal (bindat-pack spec '((x . ""))) "\0\0"))
+ (should (equal (bindat-pack spec '((x . "a"))) "a\0")))
+
+ (ert-deftest bindat-test--strz-legacy-fixedlen-pack-overflow ()
+ ;; Same comment as for b-t-s-f-pack-overflow.
+ (should (equal (bindat-pack spec '((x . "ab"))) "ab"))
+ (should (equal (bindat-pack spec '((x . "abc"))) "ab")))
+
+ (ert-deftest bindat-test--strz-legacy-fixedlen-unpack ()
+ (should (equal (bindat-unpack spec "\0\0") '((x . ""))))
+ (should (equal (bindat-unpack spec "\0X") '((x . ""))))
+ (should (equal (bindat-unpack spec "a\0") '((x . "a"))))
+ ;; Same comment as for b-t-s-f-pack-overflow.
+ (should (equal (bindat-unpack spec "ab") '((x . "ab"))))
+ ;; Missing null terminator.
+ (should-error (bindat-unpack spec ""))
+ (should-error (bindat-unpack spec "a"))))
+
;;; bindat-tests.el ends here
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el b/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el
new file mode 100644
index 00000000000..be907b32f47
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/fun-attr-warn.el
@@ -0,0 +1,266 @@
+;;; -*- lexical-binding: t -*-
+
+;; Correct
+
+(defun faw-str-decl-code (x)
+ "something"
+ (declare (pure t))
+ (print x))
+
+(defun faw-doc-decl-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (print x))
+
+(defun faw-str-int-code (x)
+ "something"
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-int-code (x)
+ (:documentation "something")
+ (interactive "P")
+ (print x))
+
+(defun faw-decl-int-code (x)
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-int-code (x)
+ "something"
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-decl-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+
+;; Correct (last string is return value)
+
+(defun faw-str ()
+ "something")
+
+(defun faw-decl-str ()
+ (declare (pure t))
+ "something")
+
+(defun faw-decl-int-str ()
+ (declare (pure t))
+ (interactive)
+ "something")
+
+(defun faw-str-str ()
+ "something"
+ "something else")
+
+(defun faw-doc-str ()
+ (:documentation "something")
+ "something else")
+
+
+;; Incorrect (bad order)
+
+(defun faw-int-decl-code (x)
+ (interactive "P")
+ (declare (pure t))
+ (print x))
+
+(defun faw-int-str-code (x)
+ (interactive "P")
+ "something"
+ (print x))
+
+(defun faw-int-doc-code (x)
+ (interactive "P")
+ (:documentation "something")
+ (print x))
+
+(defun faw-decl-str-code (x)
+ (declare (pure t))
+ "something"
+ (print x))
+
+(defun faw-decl-doc-code (x)
+ (declare (pure t))
+ (:documentation "something")
+ (print x))
+
+(defun faw-str-int-decl-code (x)
+ "something"
+ (interactive "P")
+ (declare (pure t))
+ (print x))
+
+(defun faw-doc-int-decl-code (x)
+ (:documentation "something")
+ (interactive "P")
+ (declare (pure t))
+ (print x))
+
+(defun faw-int-str-decl-code (x)
+ (interactive "P")
+ "something"
+ (declare (pure t))
+ (print x))
+
+(defun faw-int-doc-decl-code (x)
+ (interactive "P")
+ (:documentation "something")
+ (declare (pure t))
+ (print x))
+
+(defun faw-int-decl-str-code (x)
+ (interactive "P")
+ (declare (pure t))
+ "something"
+ (print x))
+
+(defun faw-int-decl-doc-code (x)
+ (interactive "P")
+ (declare (pure t))
+ (:documentation "something")
+ (print x))
+
+(defun faw-decl-int-str-code (x)
+ (declare (pure t))
+ (interactive "P")
+ "something"
+ (print x))
+
+(defun faw-decl-int-doc-code (x)
+ (declare (pure t))
+ (interactive "P")
+ (:documentation "something")
+ (print x))
+
+(defun faw-decl-str-int-code (x)
+ (declare (pure t))
+ "something"
+ (interactive "P")
+ (print x))
+
+(defun faw-decl-doc-int-code (x)
+ (declare (pure t))
+ (:documentation "something")
+ (interactive "P")
+ (print x))
+
+
+;; Incorrect (duplication)
+
+(defun faw-str-str-decl-int-code (x)
+ "something"
+ "something else"
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-str-doc-decl-int-code (x)
+ "something"
+ (:documentation "something else")
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-str-decl-int-code (x)
+ (:documentation "something")
+ "something else"
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-doc-decl-int-code (x)
+ (:documentation "something")
+ (:documentation "something else")
+ (declare (pure t))
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-str-int-code (x)
+ "something"
+ (declare (pure t))
+ "something else"
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-decl-str-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ "something else"
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-doc-int-code (x)
+ "something"
+ (declare (pure t))
+ (:documentation "something else")
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-decl-doc-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (:documentation "something else")
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-decl-int-code (x)
+ "something"
+ (declare (pure t))
+ (declare (indent 1))
+ (interactive "P")
+ (print x))
+
+(defun faw-doc-decl-decl-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (declare (indent 1))
+ (interactive "P")
+ (print x))
+
+(defun faw-str-decl-int-decl-code (x)
+ "something"
+ (declare (pure t))
+ (interactive "P")
+ (declare (indent 1))
+ (print x))
+
+(defun faw-doc-decl-int-decl-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (interactive "P")
+ (declare (indent 1))
+ (print x))
+
+(defun faw-str-decl-int-int-code (x)
+ "something"
+ (declare (pure t))
+ (interactive "P")
+ (interactive "p")
+ (print x))
+
+(defun faw-doc-decl-int-int-code (x)
+ (:documentation "something")
+ (declare (pure t))
+ (interactive "P")
+ (interactive "p")
+ (print x))
+
+(defun faw-str-int-decl-int-code (x)
+ "something"
+ (interactive "P")
+ (declare (pure t))
+ (interactive "p")
+ (print x))
+
+(defun faw-doc-int-decl-int-code (x)
+ (:documentation "something")
+ (interactive "P")
+ (declare (pure t))
+ (interactive "p")
+ (print x))
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el
new file mode 100644
index 00000000000..00ad1947507
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el
@@ -0,0 +1 @@
+;; -*- no-byte-compile: t; -*-
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-nonvariable.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-nonvariable.el
new file mode 100644
index 00000000000..5a56913cd9b
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-nonvariable.el
@@ -0,0 +1,3 @@
+;;; -*- lexical-binding: t -*-
+(defun foo ()
+ (setq (a) nil))
diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-odd.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-odd.el
new file mode 100644
index 00000000000..9ce80de08cd
--- /dev/null
+++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-setq-odd.el
@@ -0,0 +1,3 @@
+;;; -*- lexical-binding: t -*-
+(defun foo (a b)
+ (setq a 1 b))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index abd33ab8e5a..a246c25e24f 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -38,7 +38,7 @@
bytecomp-test-var)
(defun bytecomp-test-identity (x)
- "Identity, but hidden from some optimisations."
+ "Identity, but hidden from some optimizations."
x)
(defmacro bytecomp-test-loop (outer1 outer2 inner1 inner2)
@@ -556,7 +556,7 @@ inner loops respectively."
((not x) 3)))
'("a" "b" "c" "d" nil))
- ;; `let' and `let*' optimisations with body being constant or variable
+ ;; `let' and `let*' optimizations with body being constant or variable
(let* (a
(b (progn (setq a (cons 1 a)) 2))
(c (1+ b))
@@ -582,7 +582,7 @@ inner loops respectively."
(let* (x y)
'a)
- ;; Check empty-list optimisations.
+ ;; Check empty-list optimizations.
(mapcar (lambda (x) (member x nil)) '("a" 2 nil))
(mapcar (lambda (x) (memql x nil)) '(a 2 nil))
(mapcar (lambda (x) (memq x nil)) '(a nil))
@@ -597,7 +597,7 @@ inner loops respectively."
(list (mapcar (lambda (x) (assoc (setq n (1+ n)) nil)) '(a "nil"))
n))
- ;; Exercise variable-aliasing optimisations.
+ ;; Exercise variable-aliasing optimizations.
(let ((a (list 1)))
(let ((b a))
(let ((a (list 2)))
@@ -747,6 +747,7 @@ byte-compiled. Run with dynamic binding."
(ert-with-temp-file elcfile
:suffix ".elc"
(with-temp-buffer
+ (insert ";;; -*- lexical-binding: t -*-\n")
(dolist (form forms)
(print form (current-buffer)))
(write-region (point-min) (point-max) elfile nil 'silent))
@@ -950,11 +951,17 @@ byte-compiled. Run with dynamic binding."
"let-bind nonvariable")
(bytecomp--define-warning-file-test "warn-variable-set-constant.el"
- "variable reference to constant")
+ "attempt to set constant")
(bytecomp--define-warning-file-test "warn-variable-set-nonvariable.el"
"variable reference to nonvariable")
+(bytecomp--define-warning-file-test "warn-variable-setq-nonvariable.el"
+ "attempt to set non-variable")
+
+(bytecomp--define-warning-file-test "warn-variable-setq-odd.el"
+ "odd number of arguments")
+
(bytecomp--define-warning-file-test
"warn-wide-docstring-autoload.el"
"autoload .foox. docstring wider than .* characters")
@@ -1227,12 +1234,19 @@ literals (Bug#20852)."
'((lexical prefixless))
"global/dynamic var .prefixless. lacks")
- (test-suppression
- '(defun foo()
- (let ((nil t))
- (message-mail)))
- '((constants nil))
- "Warning: attempt to let-bind constant .nil.")
+ ;; FIXME: These messages cannot be suppressed reliably right now,
+ ;; but attempting mutate `nil' or `5' is a rather daft thing to do
+ ;; in the first place. Preventing mutation of constants such as
+ ;; `most-positive-fixnum' makes more sense but the compiler doesn't
+ ;; warn about that at all right now (it's caught at runtime, and we
+ ;; allow writing the same value).
+ ;;
+ ;; (test-suppression
+ ;; '(defun foo()
+ ;; (let ((nil t))
+ ;; (message-mail)))
+ ;; '((constants nil))
+ ;; "Warning: attempt to let-bind constant .nil.")
(test-suppression
'(progn
@@ -1251,7 +1265,7 @@ literals (Bug#20852)."
(defun zot ()
(wrong-params 1 2 3)))
'((callargs wrong-params))
- "Warning: wrong-params called with")
+ "Warning: .wrong-params. called with")
(test-byte-comp-compile-and-load nil
(defvar obsolete-variable nil)
@@ -1538,6 +1552,103 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \
(TEST-IN-COMMENTS t) (TEST-IN-STRINGS t) (TEST-IN-CODE t) \
(FIXTURE-FN \\='#\\='electric-pair-mode))" fill-column)))
+(defun test-bytecomp-defgroup-choice ()
+ (should-not (byte-compile--suspicious-defcustom-choice 'integer))
+ (should-not (byte-compile--suspicious-defcustom-choice
+ '(choice (const :tag "foo" bar))))
+ (should (byte-compile--suspicious-defcustom-choice
+ '(choice (const :tag "foo" 'bar)))))
+
+(ert-deftest bytecomp-function-attributes ()
+ ;; Check that `byte-compile' keeps the declarations, interactive spec and
+ ;; doc string of the function (bug#55830).
+ (let ((fname 'bytecomp-test-fun))
+ (fset fname nil)
+ (put fname 'pure nil)
+ (put fname 'lisp-indent-function nil)
+ (eval `(defun ,fname (x)
+ "tata"
+ (declare (pure t) (indent 1))
+ (interactive "P")
+ (list 'toto x))
+ t)
+ (let ((bc (byte-compile fname)))
+ (should (byte-code-function-p bc))
+ (should (equal (funcall bc 'titi) '(toto titi)))
+ (should (equal (aref bc 5) "P"))
+ (should (equal (get fname 'pure) t))
+ (should (equal (get fname 'lisp-indent-function) 1))
+ (should (equal (aref bc 4) "tata\n\n(fn X)")))))
+
+(ert-deftest bytecomp-fun-attr-warn ()
+ ;; Check that warnings are emitted when doc strings, `declare' and
+ ;; `interactive' forms don't come in the proper order, or more than once.
+ (let* ((filename "fun-attr-warn.el")
+ (el (ert-resource-file filename))
+ (elc (concat el "c"))
+ (text-quoting-style 'grave))
+ (with-current-buffer (get-buffer-create "*Compile-Log*")
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (byte-compile-file el)
+ (let ((expected
+ '("70:4: Warning: `declare' after `interactive'"
+ "74:4: Warning: Doc string after `interactive'"
+ "79:4: Warning: Doc string after `interactive'"
+ "84:4: Warning: Doc string after `declare'"
+ "89:4: Warning: Doc string after `declare'"
+ "96:4: Warning: `declare' after `interactive'"
+ "102:4: Warning: `declare' after `interactive'"
+ "108:4: Warning: `declare' after `interactive'"
+ "106:4: Warning: Doc string after `interactive'"
+ "114:4: Warning: `declare' after `interactive'"
+ "112:4: Warning: Doc string after `interactive'"
+ "118:4: Warning: Doc string after `interactive'"
+ "119:4: Warning: `declare' after `interactive'"
+ "124:4: Warning: Doc string after `interactive'"
+ "125:4: Warning: `declare' after `interactive'"
+ "130:4: Warning: Doc string after `declare'"
+ "136:4: Warning: Doc string after `declare'"
+ "142:4: Warning: Doc string after `declare'"
+ "148:4: Warning: Doc string after `declare'"
+ "159:4: Warning: More than one doc string"
+ "165:4: Warning: More than one doc string"
+ "171:4: Warning: More than one doc string"
+ "178:4: Warning: More than one doc string"
+ "186:4: Warning: More than one doc string"
+ "192:4: Warning: More than one doc string"
+ "200:4: Warning: More than one doc string"
+ "206:4: Warning: More than one doc string"
+ "215:4: Warning: More than one `declare' form"
+ "222:4: Warning: More than one `declare' form"
+ "230:4: Warning: More than one `declare' form"
+ "237:4: Warning: More than one `declare' form"
+ "244:4: Warning: More than one `interactive' form"
+ "251:4: Warning: More than one `interactive' form"
+ "258:4: Warning: More than one `interactive' form"
+ "257:4: Warning: `declare' after `interactive'"
+ "265:4: Warning: More than one `interactive' form"
+ "264:4: Warning: `declare' after `interactive'")))
+ (goto-char (point-min))
+ (let ((actual nil))
+ (while (re-search-forward
+ (rx bol (* (not ":")) ":"
+ (group (+ digit) ":" (+ digit) ": Warning: "
+ (or "More than one " (+ nonl) " form"
+ (: (+ nonl) " after " (+ nonl))))
+ eol)
+ nil t)
+ (push (match-string 1) actual))
+ (setq actual (nreverse actual))
+ (should (equal actual expected)))))))
+
+(ert-deftest byte-compile-file/no-byte-compile ()
+ (let* ((src-file (ert-resource-file "no-byte-compile.el"))
+ (dest-file (make-temp-file "bytecomp-tests-" nil ".elc"))
+ (byte-compile-dest-file-function (lambda (_) dest-file)))
+ (should (eq (byte-compile-file src-file) 'no-byte-compile))
+ (should-not (file-exists-p dest-file))))
+
;; Local Variables:
;; no-byte-compile: t
diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el
index 0668e44ba51..9904c6a969c 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -24,6 +24,7 @@
(require 'ert)
(require 'cl-lib)
(require 'generator)
+(require 'bytecomp)
(ert-deftest cconv-tests-lambda-:documentation ()
"Docstring for lambda can be specified with :documentation."
diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el
index 008ec0de4a6..19ede627a13 100644
--- a/test/lisp/emacs-lisp/cl-macs-tests.el
+++ b/test/lisp/emacs-lisp/cl-macs-tests.el
@@ -23,6 +23,7 @@
(require 'cl-lib)
(require 'cl-macs)
+(require 'edebug)
(require 'ert)
@@ -694,4 +695,36 @@ collection clause."
(list cl-macs--test1 cl-macs--test2))
'(1 2))))
+(ert-deftest cl-define-compiler-macro/edebug ()
+ "Check that we can instrument compiler macros."
+ (with-temp-buffer
+ (dolist (form '((defun cl-define-compiler-macro/edebug (a b) nil)
+ (cl-define-compiler-macro
+ cl-define-compiler-macro/edebug
+ (&whole w a b)
+ w)))
+ (print form (current-buffer)))
+ (let ((edebug-all-defs t)
+ (edebug-initial-mode 'Go-nonstop))
+ ;; Just make sure the forms can be instrumented.
+ (eval-buffer))))
+
+(ert-deftest cl-defstruct/edebug ()
+ "Check that we can instrument `cl-defstruct' forms."
+ (with-temp-buffer
+ (dolist (form '((cl-defstruct cl-defstruct/edebug/1)
+ (cl-defstruct (cl-defstruct/edebug/2
+ :noinline))
+ (cl-defstruct (cl-defstruct/edebug/3
+ (:noinline t)))
+ (cl-defstruct (cl-defstruct/edebug/4
+ :named))
+ (cl-defstruct (cl-defstruct/edebug/5
+ (:named t)))))
+ (print form (current-buffer)))
+ (let ((edebug-all-defs t)
+ (edebug-initial-mode 'Go-nonstop))
+ ;; Just make sure the forms can be instrumented.
+ (eval-buffer))))
+
;;; cl-macs-tests.el ends here
diff --git a/test/lisp/emacs-lisp/easy-mmode-tests.el b/test/lisp/emacs-lisp/easy-mmode-tests.el
index 0a3bbb189ba..f6d07196727 100644
--- a/test/lisp/emacs-lisp/easy-mmode-tests.el
+++ b/test/lisp/emacs-lisp/easy-mmode-tests.el
@@ -60,6 +60,4 @@
(easy-mmode-test-mode 'toggle)
(should (eq easy-mmode-test-mode t))))
-(provide 'easy-mmode-tests)
-
;;; easy-mmode-tests.el ends here
diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el
index 35259a796a0..008e1e467ba 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -1104,5 +1104,14 @@ This avoids potential duplicate definitions (Bug#41988)."
(edebug-initial-mode 'Go-nonstop))
(eval-buffer))))
+(ert-deftest edebug-test-dot-reader ()
+ (with-temp-buffer
+ (insert "(defun x () `(t .,t))")
+ (goto-char (point-min))
+ (should (equal (save-excursion
+ (edebug-read-storing-offsets (current-buffer)))
+ (save-excursion
+ (read (current-buffer)))))))
+
(provide 'edebug-tests)
;;; edebug-tests.el ends here
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el
index dd12e3764ce..84c28e11315 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -377,8 +377,11 @@ This macro is used to test if macroexpansion in `should' works."
(test (make-ert-test :body test-body))
(result (ert-run-test test)))
(should (ert-test-failed-p result))
- (should (eq (backtrace-frame-fun (car (ert-test-failed-backtrace result)))
- 'signal))))
+ (should (memq (backtrace-frame-fun (car (ert-test-failed-backtrace result)))
+ ;;; This is `ert-fail' on nativecomp and `signal'
+ ;;; otherwise. It's not clear whether that's a bug
+ ;;; or not (bug#51308).
+ '(ert-fail signal)))))
(ert-deftest ert-test-messages ()
:tags '(:causes-redisplay)
@@ -595,6 +598,7 @@ This macro is used to test if macroexpansion in `should' works."
(should found-complex)))))
(ert-deftest ert-test-run-tests-batch-expensive ()
+ :tags (if (getenv "EMACS_EMBA_CI") '(:unstable))
(let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc"))))))))
(failing-test-1
(make-ert-test :name 'failing-test-1
diff --git a/test/lisp/emacs-lisp/find-func-tests.el b/test/lisp/emacs-lisp/find-func-tests.el
index d29d9ff6563..420c61acb55 100644
--- a/test/lisp/emacs-lisp/find-func-tests.el
+++ b/test/lisp/emacs-lisp/find-func-tests.el
@@ -95,6 +95,13 @@ expected function symbol and function library, respectively."
(advice-remove #'mark-sexp 'my-message))
(ert-deftest find-func-tests--find-library-verbose ()
+ (unwind-protect
+ (progn
+ (advice-add 'dired :before #'ignore)
+ ;; bug#41104
+ (should (equal (find-function-library #'dired) '(dired . "dired"))))
+ (advice-remove 'dired #'ignore))
+
(find-function-library #'join-line nil t)
(with-current-buffer "*Messages*"
(save-excursion
diff --git a/test/lisp/emacs-lisp/icons-tests.el b/test/lisp/emacs-lisp/icons-tests.el
new file mode 100644
index 00000000000..e6e71a8e4fd
--- /dev/null
+++ b/test/lisp/emacs-lisp/icons-tests.el
@@ -0,0 +1,63 @@
+;;; icons-tests.el --- Tests for icons.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/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'icons)
+(require 'ert)
+(require 'ert-x)
+(require 'cus-edit)
+
+(define-icon icon-test1 nil
+ '((symbol ">")
+ (text "great"))
+ "Test icon"
+ :version "29.1")
+
+(define-icon icon-test2 icon-test1
+ '((text "child"))
+ "Test icon"
+ :version "29.1")
+
+(deftheme test-icons-theme "")
+
+(ert-deftest test-icon-theme ()
+ (let ((icon-preference '(image emoji symbol text)))
+ (should (equal (icon-string 'icon-test1) ">")))
+ (let ((icon-preference '(text)))
+ (should (equal (icon-string 'icon-test1) "great")))
+ (custom-theme-set-icons
+ 'test-icons-theme
+ '(icon-test1 ((symbol "<") (text "less"))))
+ (let ((icon-preference '(image emoji symbol text)))
+ (should (equal (icon-string 'icon-test1) ">"))
+ (enable-theme 'test-icons-theme)
+ (should (equal (icon-string 'icon-test1) "<"))))
+
+(ert-deftest test-icon-inheretance ()
+ (let ((icon-preference '(image emoji symbol text)))
+ (should (equal (icon-string 'icon-test2) ">")))
+ (let ((icon-preference '(text)))
+ (should (equal (icon-string 'icon-test2) "child"))))
+
+;;; icons-tests.el ends here
diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el
index f21624cfd87..a675986b90b 100644
--- a/test/lisp/emacs-lisp/nadvice-tests.el
+++ b/test/lisp/emacs-lisp/nadvice-tests.el
@@ -153,13 +153,13 @@ function being an around advice."
(ert-deftest advice-test-call-interactively ()
"Check interaction between advice on call-interactively and called-interactively-p."
- (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p)))
- (let ((old (symbol-function 'call-interactively)))
+ (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p))))
+ (old (symbol-function 'call-interactively)))
(unwind-protect
(progn
(advice-add 'call-interactively :before #'ignore)
- (should (equal (sm-test7.4) '(1 . nil)))
- (should (equal (call-interactively 'sm-test7.4) '(1 . t))))
+ (should (equal (funcall sm-test7.4) '(1 . nil)))
+ (should (equal (call-interactively sm-test7.4) '(1 . t))))
(advice-remove 'call-interactively #'ignore)
(should (eq (symbol-function 'call-interactively) old)))))
@@ -204,6 +204,15 @@ function being an around advice."
(remove-function (var sm-test10) sm-advice)
(should (equal (funcall sm-test10 5) 15))))
+(ert-deftest advice-test-print ()
+ (let ((x (list 'cdr)))
+ (add-function :after (car x) 'car)
+ (should (equal (cl-prin1-to-string (car x))
+ "#f(advice car :after cdr)"))
+ (add-function :before (car x) 'first)
+ (should (equal (cl-prin1-to-string (car x))
+ "#f(advice first :before #f(advice car :after cdr))"))))
+
;; Local Variables:
;; no-byte-compile: t
;; End:
diff --git a/test/lisp/emacs-lisp/oclosure-tests.el b/test/lisp/emacs-lisp/oclosure-tests.el
new file mode 100644
index 00000000000..00b008845c0
--- /dev/null
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -0,0 +1,166 @@
+;;; oclosure-tests.e; --- Tests for Open Closures -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021-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 'ert)
+(require 'oclosure)
+(require 'cl-lib)
+(require 'eieio)
+
+(oclosure-define (oclosure-test
+ (:copier oclosure-test-copy)
+ (:copier oclosure-test-copy1 (fst)))
+ "Simple OClosure."
+ fst snd (name :mutable t))
+
+(cl-defmethod oclosure-test-gen ((_x compiled-function)) "#<bytecode>")
+
+(cl-defmethod oclosure-test-gen ((_x cons)) "#<cons>")
+
+(cl-defmethod oclosure-test-gen ((_x oclosure))
+ (format "#<oclosure:%s>" (cl-call-next-method)))
+
+(cl-defmethod oclosure-test-gen ((_x oclosure-test))
+ (format "#<oclosure-test:%s>" (cl-call-next-method)))
+
+(ert-deftest oclosure-test ()
+ (let* ((i 42)
+ (ocl1 (oclosure-lambda (oclosure-test (fst 1) (snd 2) (name "hi"))
+ ()
+ (list fst snd i)))
+ (ocl2 (oclosure-lambda (oclosure-test (name (cl-incf i)) (fst (cl-incf i)))
+ ()
+ (list fst snd 152 i))))
+ (should (equal (list (oclosure-test--fst ocl1)
+ (oclosure-test--snd ocl1)
+ (oclosure-test--name ocl1))
+ '(1 2 "hi")))
+ (should (equal (list (oclosure-test--fst ocl2)
+ (oclosure-test--snd ocl2)
+ (oclosure-test--name ocl2))
+ '(44 nil 43)))
+ (should (equal (funcall ocl1) '(1 2 44)))
+ (should (equal (funcall ocl2) '(44 nil 152 44)))
+ (should (equal (funcall (oclosure-test-copy ocl1 :fst 7)) '(7 2 44)))
+ (should (equal (funcall (oclosure-test-copy1 ocl1 9)) '(9 2 44)))
+ (should (cl-typep ocl1 'oclosure-test))
+ (should (cl-typep ocl1 'oclosure))
+ (should (member (oclosure-test-gen ocl1)
+ '("#<oclosure-test:#<oclosure:#<cons>>>"
+ "#<oclosure-test:#<oclosure:#<bytecode>>>")))
+ (should (stringp (documentation #'oclosure-test--fst)))
+ ))
+
+(ert-deftest oclosure-test-limits ()
+ (defvar byte-compile-debug)
+ (should
+ (condition-case err
+ (let ((lexical-binding t)
+ (byte-compile-debug t))
+ (byte-compile '(lambda ()
+ (let ((inc-fst nil))
+ (oclosure-lambda (oclosure-test (fst 'foo)) ()
+ (setq inc-fst (lambda () (setq fst (1+ fst))))
+ fst))))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "fst.*mutated" (cadr err))))))
+ (should
+ (condition-case err
+ (progn (macroexpand-all '(oclosure-define oclosure--foo a a))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "Duplicate slot name: a$" (cadr err))))))
+ (should
+ (condition-case err
+ (progn (macroexpand-all
+ '(oclosure-define (oclosure--foo (:parent oclosure-test)) fst))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "Duplicate slot name: fst$" (cadr err))))))
+ (should
+ (condition-case err
+ (progn (macroexpand '(oclosure-lambda (oclosure-test (fst 1) (fst 2))
+ () fst))
+ nil)
+ (error
+ (and (eq 'error (car err))
+ (string-match "Duplicate slot: fst$" (cadr err)))))))
+
+(cl-defmethod oclosure-interactive-form ((ot oclosure-test))
+ (let ((snd (oclosure-test--snd ot)))
+ (if (stringp snd) (list 'interactive snd))))
+
+(ert-deftest oclosure-test-interactive-form ()
+ (should (equal (interactive-form
+ (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst))
+ nil))
+ (should (equal (interactive-form
+ (oclosure-lambda (oclosure-test (fst 1) (snd 2)) ()
+ (interactive "r")
+ fst))
+ '(interactive "r")))
+ (should (equal (interactive-form
+ (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst))
+ '(interactive "P")))
+ (should (not (commandp
+ (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst))))
+ (should (commandp
+ (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst))))
+
+(oclosure-define (oclosure-test-mut
+ (:parent oclosure-test)
+ (:copier oclosure-test-mut-copy))
+ "Simple OClosure with a mutable field."
+ (mut :mutable t))
+
+(ert-deftest oclosure-test-mutate ()
+ (let* ((f (oclosure-lambda (oclosure-test-mut (fst 0) (mut 3))
+ (x)
+ (+ x fst mut)))
+ (f2 (oclosure-test-mut-copy f :fst 50)))
+ (should (equal (oclosure-test-mut--mut f) 3))
+ (should (equal (funcall f 5) 8))
+ (should (equal (funcall f2 5) 58))
+ (cl-incf (oclosure-test-mut--mut f) 7)
+ (should (equal (oclosure-test-mut--mut f) 10))
+ (should (equal (funcall f 5) 15))
+ (should (equal (funcall f2 15) 68))))
+
+(ert-deftest oclosure-test-slot-value ()
+ (require 'eieio)
+ (let ((ocl (oclosure-lambda
+ (oclosure-test (fst 'fst1) (snd 'snd1) (name 'name1))
+ (x)
+ (list name fst snd x))))
+ (should (equal 'fst1 (slot-value ocl 'fst)))
+ (should (equal 'snd1 (slot-value ocl 'snd)))
+ (should (equal 'name1 (slot-value ocl 'name)))
+ (setf (slot-value ocl 'name) 'new-name)
+ (should (equal 'new-name (slot-value ocl 'name)))
+ (should (equal '(new-name fst1 snd1 arg) (funcall ocl 'arg)))
+ (should-error (setf (slot-value ocl 'fst) 'new-fst) :type 'setting-constant)
+ (should (equal 'fst1 (slot-value ocl 'fst)))
+ ))
+
+;;; oclosure-tests.el ends here.
diff --git a/test/lisp/emacs-lisp/pp-resources/code-formats.erts b/test/lisp/emacs-lisp/pp-resources/code-formats.erts
index 002a5cf1650..c3e3023cb19 100644
--- a/test/lisp/emacs-lisp/pp-resources/code-formats.erts
+++ b/test/lisp/emacs-lisp/pp-resources/code-formats.erts
@@ -128,3 +128,15 @@ Name: code-formats12
=-=
(global-set-key (kbd "s-x") #'kill-region)
=-=-=
+
+Name: code-formats13
+
+=-=
+'("a")
+=-=-=
+
+Name: code-formats14
+
+=-=
+'("a" . "b")
+=-=-=
diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el
index c1c46d6400e..385b0fe44a5 100644
--- a/test/lisp/emacs-lisp/rmc-tests.el
+++ b/test/lisp/emacs-lisp/rmc-tests.el
@@ -66,5 +66,26 @@
(should (equal (list char str)
(read-multiple-choice "Do it? " '((?y "yes") (?n "no"))))))))
-(provide 'rmc-tests)
+(ert-deftest test-read-multiple-choice-help ()
+ (let ((chars '(?o ?a))
+ help)
+ (cl-letf* (((symbol-function #'read-event)
+ (lambda ()
+ (message "chars %S" chars)
+ (when (= 1 (length chars))
+ (with-current-buffer "*Multiple Choice Help*"
+ (setq help (buffer-string))))
+ (pop chars))))
+ (read-multiple-choice
+ "Choose:"
+ '((?a "aaa")
+ (?b "bbb")
+ (?c "ccc" "a really long description of ccc")))
+ (should (equal help "Choose:
+
+a: [A]aa b: [B]bb c: [C]cc
+ a really long
+ description of ccc
+ \n")))))
+
;;; rmc-tests.el ends here
diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el
index 9e5d59163f9..3b22e42df24 100644
--- a/test/lisp/emacs-lisp/seq-tests.el
+++ b/test/lisp/emacs-lisp/seq-tests.el
@@ -257,6 +257,19 @@ Evaluate BODY for each created sequence.
(with-test-sequences (seq '())
(should (equal (seq-uniq seq) '()))))
+(defun seq-tests--list-subseq-ref (list start &optional end)
+ "Reference implementation of `seq-subseq' for lists."
+ (let ((len (length list)))
+ (when (< start 0)
+ (setq start (+ start len)))
+ (unless end
+ (setq end len))
+ (when (< end 0)
+ (setq end (+ end len)))
+ (if (<= 0 start end len)
+ (take (- end start) (nthcdr start list))
+ (error "bad args"))))
+
(ert-deftest test-seq-subseq ()
(with-test-sequences (seq '(2 3 4 5))
(should (equal (seq-subseq seq 0 4) seq))
@@ -275,7 +288,21 @@ Evaluate BODY for each created sequence.
(should-error (seq-subseq [] -1))
(should-error (seq-subseq "" -1))
(should-not (seq-subseq '() 0))
- (should-error (seq-subseq '() 0 -1)))
+ (should-error (seq-subseq '() 0 -1))
+
+ (dolist (list '(() (a b c d)))
+ (ert-info ((prin1-to-string list) :prefix "list: ")
+ (let ((len (length list)))
+ (dolist (start (number-sequence (- -2 len) (+ 2 len)))
+ (ert-info ((prin1-to-string start) :prefix "start: ")
+ (dolist (end (cons nil (number-sequence (- -2 len) (+ 2 len))))
+ (ert-info ((prin1-to-string end) :prefix "end: ")
+ (condition-case res
+ (seq-tests--list-subseq-ref list start end)
+ (error
+ (should-error (seq-subseq list start end)))
+ (:success
+ (should (equal (seq-subseq list start end) res))))))))))))
(ert-deftest test-seq-concatenate ()
(with-test-sequences (seq '(2 4 6))
@@ -511,5 +538,26 @@ Evaluate BODY for each created sequence.
(should (equal (seq-difference '(1 nil) '(2 nil))
'(1)))))
+(ert-deftest test-seq-split ()
+ (let ((seq [0 1 2 3 4 5 6 7 8 9 10]))
+ (should (equal seq (car (seq-split seq 20))))
+ (should (equal seq (car (seq-split seq 11))))
+ (should (equal (seq-split seq 10)
+ '([0 1 2 3 4 5 6 7 8 9] [10])))
+ (should (equal (seq-split seq 5)
+ '([0 1 2 3 4] [5 6 7 8 9] [10])))
+ (should (equal (seq-split seq 1)
+ '([0] [1] [2] [3] [4] [5] [6] [7] [8] [9] [10])))
+ (should-error (seq-split seq 0))
+ (should-error (seq-split seq -10)))
+ (let ((seq '(0 1 2 3 4 5 6 7 8 9)))
+ (should (equal (seq-split seq 5)
+ '((0 1 2 3 4) (5 6 7 8 9)))))
+ (let ((seq "0123456789"))
+ (should (equal (seq-split seq 2)
+ '("01" "23" "45" "67" "89")))
+ (should (equal (seq-split seq 3)
+ '("012" "345" "678" "9")))))
+
(provide 'seq-tests)
;;; seq-tests.el ends here
diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el
index d38a8e2352b..7a3efe9db62 100644
--- a/test/lisp/emacs-lisp/subr-x-tests.el
+++ b/test/lisp/emacs-lisp/subr-x-tests.el
@@ -607,21 +607,36 @@
(should (equal (string-limit "foó" 4 nil 'utf-8) "fo\303\263"))
(should (equal (string-limit "foóa" 4 nil 'utf-8) "fo\303\263"))
(should (equal (string-limit "foóá" 4 nil 'utf-8) "fo\303\263"))
+ (should (equal (string-limit "foóá" 2 nil 'utf-8-with-signature)
+ ""))
(should (equal (string-limit "foóá" 4 nil 'utf-8-with-signature)
- "fo\303\263"))
+ "\357\273\277f"))
(should (equal (string-limit "foóa" 4 nil 'iso-8859-1) "fo\363a"))
(should (equal (string-limit "foóá" 4 nil 'iso-8859-1) "fo\363\341"))
- (should (equal (string-limit "foóá" 4 nil 'utf-16) "\000f\000o"))
+ (should (equal (string-limit "foóá" 3 nil 'utf-16) ""))
+ (should (equal (string-limit "foóá" 6 nil 'utf-16) "\376\377\000f\000o"))
(should (equal (string-limit "foó" 10 t 'utf-8) "fo\303\263"))
(should (equal (string-limit "foó" 3 t 'utf-8) "o\303\263"))
(should (equal (string-limit "foó" 4 t 'utf-8) "fo\303\263"))
(should (equal (string-limit "foóa" 4 t 'utf-8) "o\303\263a"))
(should (equal (string-limit "foóá" 4 t 'utf-8) "\303\263\303\241"))
- (should (equal (string-limit "foóá" 2 t 'utf-8-with-signature) "\303\241"))
+ (should (equal (string-limit "foóá" 2 t 'utf-8-with-signature)
+ ""))
(should (equal (string-limit "foóa" 4 t 'iso-8859-1) "fo\363a"))
(should (equal (string-limit "foóá" 4 t 'iso-8859-1) "fo\363\341"))
- (should (equal (string-limit "foóá" 4 t 'utf-16) "\000\363\000\341")))
+ (should (equal (string-limit "foóá" 6 t 'utf-16) "\376\377\000\363\000\341")))
+
+(ert-deftest subr-string-limit-glyphs ()
+ (should (equal (encode-coding-string "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻" 'utf-8)
+ "Hello, \360\237\221\274\360\237\217\273\360\237\247\221\360\237\217\274\342\200\215\360\237\244\235\342\200\215\360\237\247\221\360\237\217\273"))
+ (should (= (length (encode-coding-string "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻" 'utf-8)) 41))
+ (should (equal (string-limit "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻" 100 nil 'utf-8)
+ "Hello, \360\237\221\274\360\237\217\273\360\237\247\221\360\237\217\274\342\200\215\360\237\244\235\342\200\215\360\237\247\221\360\237\217\273"))
+ (should (equal (string-limit "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻" 15 nil 'utf-8)
+ "Hello, \360\237\221\274\360\237\217\273"))
+ (should (equal (string-limit "Hello, 👼🏻🧑🏼‍🤝‍🧑🏻" 10 nil 'utf-8)
+ "Hello, ")))
(ert-deftest subr-string-lines ()
(should (equal (string-lines "foo") '("foo")))
@@ -712,5 +727,49 @@
(loop (cdr rest) (+ sum (car rest))))))
(should (equal (mapcar #'funcall funs) '(43 1 0)))))
+(ert-deftest test-with-buffer-unmodified-if-unchanged ()
+ (with-temp-buffer
+ (with-buffer-unmodified-if-unchanged
+ (insert "t"))
+ (should (buffer-modified-p)))
+
+ (with-temp-buffer
+ (with-buffer-unmodified-if-unchanged
+ (insert "t")
+ (delete-char -1))
+ (should-not (buffer-modified-p)))
+
+ ;; Shouldn't error.
+ (should
+ (with-temp-buffer
+ (with-buffer-unmodified-if-unchanged
+ (insert "t")
+ (delete-char -1)
+ (kill-buffer))))
+
+ (with-temp-buffer
+ (let ((outer (current-buffer)))
+ (with-temp-buffer
+ (let ((inner (current-buffer)))
+ (with-buffer-unmodified-if-unchanged
+ (insert "t")
+ (delete-char -1)
+ (set-buffer outer))
+ (with-current-buffer inner
+ (should-not (buffer-modified-p))))))))
+
+(ert-deftest subr-x--hash-table-keys-and-values ()
+ (let ((h (make-hash-table)))
+ (puthash 'a 1 h)
+ (puthash 'c 3 h)
+ (puthash 'b 2 h)
+ (should (equal (sort (hash-table-keys h) #'string<) '(a b c)))
+ (should (equal (sort (hash-table-values h) #'<) '(1 2 3)))))
+
+(ert-deftest test-string-truncate-left ()
+ (should (equal (string-truncate-left "band" 3) "...d"))
+ (should (equal (string-truncate-left "band" 2) "...d"))
+ (should (equal (string-truncate-left "longstring" 8) "...tring")))
+
(provide 'subr-x-tests)
;;; subr-x-tests.el ends here
diff --git a/test/lisp/emacs-lisp/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el
index d137572f304..98fdd55e85f 100644
--- a/test/lisp/emacs-lisp/text-property-search-tests.el
+++ b/test/lisp/emacs-lisp/text-property-search-tests.el
@@ -156,20 +156,19 @@
;;;; Position after search.
-(defun text-property-search--pos-test (fun pos &optional reverse)
+(ert-deftest text-property-search-forward/point-at-beginning ()
(with-temp-buffer
- (insert (concat "foo "
- (propertize "bar" 'x t)
- " baz"))
- (goto-char (if reverse (point-max) (point-min)))
- (funcall fun 'x t)
- (should (= (point) pos))))
-
-(ert-deftest text-property-search-forward-point-at-beginning ()
- (text-property-search--pos-test #'text-property-search-forward 5))
-
-(ert-deftest text-property-search-backward-point-at-end ()
- (text-property-search--pos-test #'text-property-search-backward 8 t))
+ (insert (concat "1234" (propertize "567" 'x t) "890"))
+ (goto-char (point-min))
+ (text-property-search-forward 'x t)
+ (should (= (point) 5))))
+
+(ert-deftest text-property-search-backward/point-at-end ()
+ (with-temp-buffer
+ (insert (concat "1234" (propertize "567" 'x t) "890"))
+ (goto-char (point-max))
+ (text-property-search-backward 'x t)
+ (should (= (point) 8))))
(provide 'text-property-search-tests)
diff --git a/test/lisp/emacs-lisp/vtable-tests.el b/test/lisp/emacs-lisp/vtable-tests.el
new file mode 100644
index 00000000000..627d9f9c5df
--- /dev/null
+++ b/test/lisp/emacs-lisp/vtable-tests.el
@@ -0,0 +1,42 @@
+;;; vtable-tests.el --- Tests for vtable.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/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'vtable)
+(require 'ert)
+(require 'ert-x)
+
+(ert-deftest test-vstable-compute-columns ()
+ (should
+ (equal (mapcar
+ (lambda (column)
+ (vtable-column-align column))
+ (vtable--compute-columns
+ (make-vtable :columns '("a" "b" "c")
+ :objects '(("foo" 1 2)
+ ("bar" 3 :zot))
+ :insert nil)))
+ '(left right left))))
+
+;;; vtable-tests.el ends here