diff options
Diffstat (limited to 'test/lisp/emacs-lisp')
21 files changed, 832 insertions, 86 deletions
diff --git a/test/lisp/emacs-lisp/benchmark-tests.el b/test/lisp/emacs-lisp/benchmark-tests.el index 8de7818bdbf..26bd3ff08a8 100644 --- a/test/lisp/emacs-lisp/benchmark-tests.el +++ b/test/lisp/emacs-lisp/benchmark-tests.el @@ -23,29 +23,37 @@ (require 'ert) (ert-deftest benchmark-tests () - (let (str t-long t-short) - (should (consp (benchmark-run nil (1+ 0)))) - (should (consp (benchmark-run 1 (1+ 0)))) + (let (str t-long t-short m) + (should (consp (benchmark-run nil (setq m (1+ 0))))) + (should (consp (benchmark-run 1 (setq m (1+ 0))))) (should (stringp (benchmark nil (1+ 0)))) (should (stringp (benchmark 1 (1+ 0)))) - (should (consp (benchmark-run-compiled nil (1+ 0)))) + (should (consp (benchmark-run-compiled (1+ 0)))) (should (consp (benchmark-run-compiled 1 (1+ 0)))) ;; First test is heavier, must need longer time. - (should (> (car (benchmark-run nil + (let ((count1 0) + (count2 0) + (repeat 2)) + (ignore (benchmark-run (setq count1 (1+ count1)))) + (ignore (benchmark-run repeat (setq count2 (1+ count2)))) + (should (> count2 count1))) + (should (> (car (benchmark-run (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run nil (1+ 0))))) - (should (> (car (benchmark-run nil + (car (benchmark-run (setq m (1+ 0)))))) + (should (> (car (benchmark-run (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run nil (1+ 0))))) - (should (> (car (benchmark-run-compiled nil + (car (benchmark-run (setq m (1+ 0)))))) + (should (> (car (benchmark-run-compiled (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run-compiled nil (1+ 0))))) + (car (benchmark-run-compiled (1+ 0))))) (setq str (benchmark nil '(let ((n 100000)) (while (> n 1) (setq n (1- n)))))) (string-match "Elapsed time: \\([0-9.]+\\)" str) (setq t-long (string-to-number (match-string 1 str))) (setq str (benchmark nil '(1+ 0))) (string-match "Elapsed time: \\([0-9.]+\\)" str) (setq t-short (string-to-number (match-string 1 str))) - (should (> t-long t-short)))) + (should (> t-long t-short)) + ;; Silence compiler. + m)) ;;; benchmark-tests.el ends here. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 13df5912eef..7c5aa9abedd 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -27,6 +27,7 @@ (require 'ert) (require 'cl-lib) +(require 'bytecomp) ;;; Code: (defconst byte-opt-testsuite-arith-data @@ -38,8 +39,7 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (+ a -1 b)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (- a 1 (- b))) - ;; This fails. Should it be a bug? - ;; (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) + (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) (let ((a 1.0)) (* a 0)) (let ((a 1.0)) (* a 2.0 0)) (let ((a 1.0)) (/ 0 a)) @@ -244,6 +244,9 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) (let ((a 3) (b 2) (c 1.0)) (/ a b c -1)) + + (let ((a t)) (logand 0 a)) + ;; Test switch bytecode (let ((a 3)) (cond ((eq a 1) 'one) ((eq a 2) 'two) ((eq a 3) 'three) (t t))) (let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3) @@ -534,23 +537,17 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--old-style-backquotes () "Check that byte compiling warns about old-style backquotes." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (write-region "(` (a b))" nil source) (bytecomp-tests--with-temp-file destination (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-error-on-warn t) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) - (list "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual."))))))) + (byte-compile-debug t) + (err (should-error (byte-compile-file source)))) + (should (equal (cdr err) '("Old-style backquotes detected!"))))))) (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1) (function-put 'bytecomp-tests--foo 'bar 2) @@ -575,6 +572,38 @@ and will be removed soon. See (elisp)Backquote in the manual."))))))) (goto-char (point-min)) (should-not (search-forward "Warning" nil t)))) +(ert-deftest bytecomp-test-featurep-warnings () + (let ((byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + (unwind-protect + (progn + (with-temp-buffer + (insert "\ +\(defun foo () + (an-undefined-function)) + +\(defun foo1 () + (if (featurep 'xemacs) + (some-undefined-function-if))) + +\(defun foo2 () + (and (featurep 'xemacs) + (some-undefined-function-and))) + +\(defun foo3 () + (if (not (featurep 'emacs)) + (some-undefined-function-not))) + +\(defun foo4 () + (or (featurep 'emacs) + (some-undefined-function-or))) +") + (byte-compile-from-buffer (current-buffer))) + (with-current-buffer byte-compile-log-buffer + (should (search-forward "an-undefined-function" nil t)) + (should-not (search-forward "some-undefined-function" nil t)))) + (if (buffer-live-p byte-compile-log-buffer) + (kill-buffer byte-compile-log-buffer))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 26bc6188738..f100e8c6c5f 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -201,6 +201,10 @@ :b :a :a 42) '(42 :a)))) +(ert-deftest cl-lib-empty-keyargs () + (should-error (funcall (cl-function (lambda (&key) 1)) + :b 1))) + (cl-defstruct (mystruct (:constructor cl-lib--con-1 (&aux (abc 1))) (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) @@ -512,6 +516,17 @@ (ert-deftest cl-lib-symbol-macrolet-2 () (should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5)))) + +(ert-deftest cl-lib-symbol-macrolet-hide () + ;; bug#26325, bug#26073 + (should (equal (let ((y 5)) + (cl-symbol-macrolet ((x y)) + (list x + (let ((x 6)) (list x y)) + (cl-letf ((x 6)) (list x y)) + (apply (lambda (x) (+ x 1)) (list 8))))) + '(5 (6 5) (6 6) 9)))) + (defun cl-lib-tests--dummy-function () ;; Dummy function to see if the file is compiled. t) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index f0bde7af397..6e9fb44b4b0 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -497,4 +497,20 @@ collection clause." vconcat (vector (1+ x))) [2 3 4 5 6]))) +(ert-deftest cl-macs-loop-for-as-equals-and () + "Test for https://debbugs.gnu.org/29799 ." + (let ((arr (make-vector 3 0))) + (should (equal '((0 0) (1 1) (2 2)) + (cl-loop for k below 3 for x = k and z = (elt arr k) + collect (list k x)))))) + + +(ert-deftest cl-defstruct/builtin-type () + (should-error + (macroexpand '(cl-defstruct hash-table)) + :type 'wrong-type-argument) + (should-error + (macroexpand '(cl-defstruct (hash-table (:predicate hash-table-p)))) + :type 'wrong-type-argument)) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-preloaded-tests.el b/test/lisp/emacs-lisp/cl-preloaded-tests.el new file mode 100644 index 00000000000..9d5feee396a --- /dev/null +++ b/test/lisp/emacs-lisp/cl-preloaded-tests.el @@ -0,0 +1,33 @@ +;;; cl-preloaded-tests.el --- unit tests for cl-preloaded.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. +;; Author: Philipp Stephani <phst@google.com> + +;; 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 this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Unit tests for lisp/emacs-lisp/cl-preloaded.el. + +;;; Code: + +(ert-deftest cl-struct-define/builtin-type () + (should-error + (cl-struct-define 'hash-table nil nil 'record nil nil + 'cl-preloaded-tests-tag 'cl-preloaded-tests nil) + :type 'wrong-type-argument)) + +;;; cl-preloaded-tests.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index c6da9e15fa3..52014aea01e 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -326,7 +326,7 @@ ) (ert-deftest eieio-test-method-order-list-9 () - (should (eitest-Jd "test"))) + (should (eitest-Jd))) ;;; call-next-method with replacement arguments across a simple class hierarchy. ;; @@ -372,7 +372,7 @@ (ert-deftest eieio-test-method-order-list-10 () (let ((eieio-test-call-next-method-arguments nil)) - (CNM-M (CNM-2 "") '(INIT)) + (CNM-M (CNM-2) '(INIT)) (should (equal (eieio-test-arguments-for 'CNM-0) '(CNM-1-1 CNM-2 INIT))) (should (equal (eieio-test-arguments-for 'CNM-1-1) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index eae69c89eb2..f5c25e64912 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -107,7 +107,7 @@ This is usually a symbol that starts with `:'." (ert-deftest eieio-test-persist-simple-1 () (let ((persist-simple-1 - (persist-simple "simple 1" :slot1 'goose :slot2 "testing" + (persist-simple :slot1 'goose :slot2 "testing" :file (concat default-directory "test-ps1.pt")))) (should persist-simple-1) @@ -141,7 +141,7 @@ Assume SLOTVALUE is a symbol of some sort." (ert-deftest eieio-test-persist-printer () (let ((persist-:printer-1 - (persist-:printer "persist" :slot1 'goose :slot2 "testing" + (persist-:printer :slot1 'goose :slot2 "testing" :file (concat default-directory "test-ps2.pt")))) (should persist-:printer-1) (persist-test-save-and-compare persist-:printer-1) @@ -178,8 +178,7 @@ persistent class.") (ert-deftest eieio-test-non-persistent-as-slot () (let ((persist-wos (persistent-with-objs-slot - "persist wos 1" - :pnp (persist-not-persistent "pnp 1" :slot1 3) + :pnp (persist-not-persistent :slot1 3) :file (concat default-directory "test-ps3.pt")))) (persist-test-save-and-compare persist-wos) @@ -205,8 +204,7 @@ persistent class.") (ert-deftest eieio-test-non-persistent-as-slot-child () (let ((persist-woss (persistent-with-objs-slot-subs - "persist woss 1" - :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3) + :pnp (persist-not-persistent-subclass :slot1 3) :file (concat default-directory "test-ps4.pt")))) (persist-test-save-and-compare persist-woss) @@ -228,7 +226,7 @@ persistent class.") (ert-deftest eieio-test-multiple-class-slot () (let ((persist - (persistent-multiclass-slot "random string" + (persistent-multiclass-slot :slot1 (persistent-random-class) :slot2 (persist-not-persistent) :slot3 (persistent-random-class) @@ -249,10 +247,9 @@ persistent class.") (ert-deftest eieio-test-slot-with-list-of-objects () (let ((persist-wols (persistent-with-objs-list-slot - "persist wols 1" - :pnp (list (persist-not-persistent "pnp 1" :slot1 3) - (persist-not-persistent "pnp 2" :slot1 4) - (persist-not-persistent "pnp 3" :slot1 5)) + :pnp (list (persist-not-persistent :slot1 3) + (persist-not-persistent :slot1 4) + (persist-not-persistent :slot1 5)) :file (concat default-directory "test-ps5.pt")))) (persist-test-save-and-compare persist-wols) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 5ba094c0072..74c76609b87 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -689,7 +689,7 @@ Do not override for `prot-2'." (defvar eitest-II2 nil) (defvar eitest-II3 nil) (ert-deftest eieio-test-29-instance-inheritor () - (setq eitest-II1 (II "II Test.")) + (setq eitest-II1 (II)) (oset eitest-II1 slot2 'cat) (setq eitest-II2 (clone eitest-II1 "eitest-II2 Test.")) (oset eitest-II2 slot1 'moose) diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el new file mode 100644 index 00000000000..7d1a128694c --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el @@ -0,0 +1,76 @@ +;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Dummy major-mode for testing `faceup', a regression test system for +;; font-lock keywords (syntax highlighting rules for Emacs). +;; +;; This mode use `syntax-propertize' to set the `syntax-table' +;; property on "<" and ">" in "<TEXT>" to make them act like +;; parentheses. +;; +;; This mode also sets the `help-echo' property on the text WARNING, +;; the effect is that Emacs displays a tooltip when you move your +;; mouse on to the text. + +;;; Code: + +(defvar faceup-test-mode-syntax-table + (make-syntax-table) + "Syntax table for `faceup-test-mode'.") + +(defvar faceup-test-font-lock-keywords + '(("\\_<WARNING\\_>" + (0 (progn + (add-text-properties (match-beginning 0) + (match-end 0) + '(help-echo "Baloon tip: Fly smoothly!")) + font-lock-warning-face)))) + "Highlight rules for `faceup-test-mode'.") + +(defun faceup-test-syntax-propertize (start end) + (goto-char start) + (funcall + (syntax-propertize-rules + ("\\(<\\)\\([^<>\n]*\\)\\(>\\)" + (1 "() ") + (3 ")( "))) + start end)) + +(defmacro faceup-test-define-prog-mode (mode name &rest args) + "Define a major mode for a programming language. +If `prog-mode' is defined, inherit from it." + (declare (indent defun)) + `(define-derived-mode + ,mode ,(and (fboundp 'prog-mode) 'prog-mode) + ,name ,@args)) + +(faceup-test-define-prog-mode faceup-test-mode "faceup-test" + "Dummy major mode for testing `faceup', a test system for font-lock." + (set (make-local-variable 'syntax-propertize-function) + #'faceup-test-syntax-propertize) + (setq font-lock-defaults '(faceup-test-font-lock-keywords nil))) + +(provide 'faceup-test-mode) + +;;; faceup-test-mode.el ends here diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el new file mode 100644 index 00000000000..0558bd12e5f --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -0,0 +1,32 @@ +;;; faceup-test-this-file-directory.el --- Support file for faceup tests + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Support file for `faceup-test-basics.el'. This file is used to test +;; `faceup-this-file-directory' in various contexts. + +;;; Code: + +(defvar faceup-test-this-file-directory (faceup-this-file-directory)) + +;;; faceup-test-this-file-directory.el ends here diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt new file mode 100644 index 00000000000..d971f364c2d --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +WARNING: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode "<" and ">" are parentheses, but only when on the same +line without any other "<" and ">" characters between them. +<OK> <NOT <OK> > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup new file mode 100644 index 00000000000..7d4938adf17 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +«(help-echo):"Baloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» are parentheses, but only when on the same +line without any other «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» characters between them. +«(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» <NOT «(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el new file mode 100644 index 00000000000..f910a1d732a --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -0,0 +1,269 @@ +;;; faceup-test-basics.el --- Tests for the `faceup' package. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Basic tests for the `faceup' package. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'faceup) + +(ert-deftest faceup-functions () + "Test primitive functions." + (should (equal (faceup-normalize-face-property '()) '())) + (should (equal (faceup-normalize-face-property 'a) '(a))) + (should (equal (faceup-normalize-face-property '(a)) '(a))) + (should (equal (faceup-normalize-face-property '(:x t)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a b)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t)) '(a (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t)) + '(a b (:x t)))) + + (should (equal (faceup-normalize-face-property '(:x t :y nil)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a b)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t :y nil)) + '(a (:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t :y nil)) + '(a b (:y nil) (:x t))))) + + +(ert-deftest faceup-markup-basics () + (should (equal (faceup-markup-string "") "")) + (should (equal (faceup-markup-string "test") "test"))) + +(ert-deftest faceup-markup-escaping () + (should (equal (faceup-markup-string "«") "««")) + (should (equal (faceup-markup-string "«A«B«C«") "««A««B««C««")) + (should (equal (faceup-markup-string "»") "«»")) + (should (equal (faceup-markup-string "»A»B»C»") "«»A«»B«»C«»"))) + +(ert-deftest faceup-markup-plain () + ;; UU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face underline))) + "AB«U:CD»EF"))) + +(ert-deftest faceup-markup-plain-full-text () + ;; UUUUUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face underline))) + "«U:ABCDEF»"))) + +(ert-deftest faceup-markup-anonymous-face () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:underline t)))) + "AB«:(:underline t):CD»EF"))) + +(ert-deftest faceup-markup-anonymous-face-2keys () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:foo t :bar nil)))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Plist in list. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t :bar nil))))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Two plists. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t) (:bar nil))))) + "AB«:(:bar nil):«:(:foo t):CD»»EF"))) + +(ert-deftest faceup-markup-anonymous-nested () + ;; AA + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face ((:foo t))) + 2 4 (face ((:bar t) (:foo t))) + 4 5 (face ((:foo t))))) + "A«:(:foo t):B«:(:bar t):CD»E»F"))) + +(ert-deftest faceup-markup-nested () + ;; UU + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face italic))) + "A«I:B«U:CD»E»F"))) + +(ert-deftest faceup-markup-overlapping () + ;; UUU + ;; III + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face underline))) + "A«I:B«U:CD»»«U:E»F")) + ;; III + ;; UUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (italic underline)) + 4 5 (face underline))) + "A«I:B»«U:«I:CD»E»F"))) + +(ert-deftest faceup-markup-multi-face () + ;; More than one face at the same location. + ;; + ;; The property to the front takes precedence, it is rendered as the + ;; innermost parenthesis pair. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (underline italic)))) + "AB«I:«U:CD»»EF")) + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (italic underline)))) + "AB«U:«I:CD»»EF")) + ;; Equal ranges, full text. + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face (underline italic)))) + "«I:«U:ABCDEF»»")) + ;; Ditto, with stray markup characters. + (should (equal (faceup-markup-string + #("AB«CD»EF" 0 8 (face (underline italic)))) + "«I:«U:AB««CD«»EF»»"))) + +(ert-deftest faceup-markup-multi-property () + (let ((faceup-properties '(alpha beta gamma))) + ;; One property. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (alpha (a l p h a)))) + "AB«(alpha):(a l p h a):CD»EF")) + + ;; Two properties, inner enclosed. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 8 '(alpha (a l p h a)) s) + (font-lock-append-text-property 4 6 'beta '(b e t a) s) + s)) + "AB«(alpha):(a l p h a):CD«(beta):(b e t a):EF»GH»IJ")) + + ;; Two properties, same end + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGH"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 6 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»GH")) + + ;; Two properties, overlap. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 8 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»«(beta):(b):GH»IJ")))) + + +(ert-deftest faceup-clean () + "Test the clean features of `faceup'." + (should (equal (faceup-clean-string "") "")) + (should (equal (faceup-clean-string "test") "test")) + (should (equal (faceup-clean-string "AB«U:CD»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«U:ABCDEF»") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»E»F") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»»«U:E»F") "ABCDEF")) + (should (equal (faceup-clean-string "AB«I:«U:CD»»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«I:«U:ABCDEF»»") "ABCDEF")) + (should (equal (faceup-clean-string "«(foo)I:ABC»DEF") "ABCDEF")) + (should (equal (faceup-clean-string "«:(:foo t):ABC»DEF") "ABCDEF")) + ;; Escaped markup characters. + (should (equal (faceup-clean-string "««") "«")) + (should (equal (faceup-clean-string "«»") "»")) + (should (equal (faceup-clean-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(ert-deftest faceup-render () + "Test the render features of `faceup'." + (should (equal (faceup-render-string "") "")) + (should (equal (faceup-render-string "««") "«")) + (should (equal (faceup-render-string "«»") "»")) + (should (equal (faceup-render-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(defvar faceup-test-resources-directory + (concat (file-name-directory + (substring (faceup-this-file-directory) 0 -1)) + "faceup-resources/") + "The `faceup-resources' directory.") + + +(defvar faceup-test-this-file-directory nil + "The result of `faceup-this-file-directory' in various contexts. + +This is set by the file test support file +`faceup-test-this-file-directory.el'.") + + +(ert-deftest faceup-directory () + "Test `faceup-this-file-directory'." + (let ((file (concat faceup-test-resources-directory + "faceup-test-this-file-directory.el")) + (load-file-name nil)) + ;; Test normal load. + (makunbound 'faceup-test-this-file-directory) + (load file nil :nomessage) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-buffer'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (eval-buffer)) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-defun'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + ;; Note: In batch mode, this prints the result of the + ;; evaluation. Unfortunately, this is hard to fix. + (eval-defun nil) + (forward-sexp)))) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)))) + +(provide 'faceup-test-basics) + +;;; faceup-test-basics.el ends here diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el new file mode 100644 index 00000000000..8df38bcc8a9 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el @@ -0,0 +1,63 @@ +;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Self test of `faceup' with a major mode that sets both the +;; `syntax-table' and the `echo-help' property. +;; +;; This file can also be seen as a blueprint of test cases for real +;; major modes. + +;;; Code: + +(require 'faceup) + +;; Note: The byte compiler needs the value to load `faceup-test-mode', +;; hence the `eval-and-compile'. +(eval-and-compile + (defvar faceup-test-files-dir (faceup-this-file-directory) + "The directory of this file.")) + +(require 'faceup-test-mode + (concat faceup-test-files-dir + "../faceup-resources/" + "faceup-test-mode.el")) + +(defun faceup-test-files-check-one (file) + "Test that FILE is fontified as the .faceup file describes. + +FILE is interpreted as relative to this source directory." + (let ((faceup-properties '(face syntax-table help-echo))) + (faceup-test-font-lock-file 'faceup-test-mode + (concat + faceup-test-files-dir + "../faceup-resources/" + file)))) +(faceup-defexplainer faceup-test-files-check-one) + +(ert-deftest faceup-files () + (should (faceup-test-files-check-one "files/test1.txt"))) + +(provide 'faceup-test-files) + +;;; faceup-test-files.el ends here diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index 9bf8413e159..bca3efa550b 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -292,3 +292,13 @@ identical output. (i 0) (j (setq i (1+ i)))) (iter-yield i)))))))) + +(ert-deftest iter-lambda-variable-shadowing () + "`iter-lambda' forms which have local variable shadowing (Bug#26073)." + (should (equal (iter-next + (funcall (iter-lambda () + (let ((it 1)) + (iter-yield (funcall + (lambda (it) (- it)) + (1+ it))))))) + -2))) diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 62fba58919f..0059c546ac2 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -473,8 +473,8 @@ Must called from within a `tar-mode' buffer." (let ((process-environment (cons (format "HOME=%s" homedir) process-environment))) - (epg-check-configuration (epg-configuration)) - (epg-find-configuration 'OpenPGP)) + (epg-check-configuration + (epg-find-configuration 'OpenPGP))) (delete-directory homedir t))))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) (package-test-data-dir @@ -484,14 +484,16 @@ Must called from within a `tar-mode' buffer." (package-import-keyring keyring) (package-refresh-contents) (let ((package-check-signature 'allow-unsigned)) - (should (package-install 'signed-good)) + (should (progn (package-install 'signed-good) 'noerror)) (should-error (package-install 'signed-bad))) + (package-delete (car (alist-get 'signed-good package-alist))) (let ((package-check-signature t)) - (should (package-install 'signed-good)) + (should (progn (package-install 'signed-good) 'noerror)) (should-error (package-install 'signed-bad))) + (package-delete (car (alist-get 'signed-good package-alist))) (let ((package-check-signature nil)) - (should (package-install 'signed-good)) - (should (package-install 'signed-bad))) + (should (progn (package-install 'signed-good) 'noerror)) + (should (progn (package-install 'signed-bad) 'noerror))) ;; Check if the installed package status is updated. (let ((buf (package-list-packages))) (package-menu-refresh) diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index c9618f3c37f..f7f0ef384f6 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -148,34 +148,34 @@ "Test `if-let' with falsie bindings." (should (equal (if-let* ((a nil)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a nil) (b 2) (c 3)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a 1) (b nil) (c 3)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a 1) (b 2) (c nil)) - (list a b c) + "yes" "no") "no")) (should (equal (let (z) (if-let* (z (a 1) (b 2) (c 3)) - (list a b c) + "yes" "no")) "no")) (should (equal (let (d) (if-let* ((a 1) (b 2) (c 3) d) - (list a b c) + "yes" "no")) "no"))) @@ -312,34 +312,28 @@ "Test `when-let' with falsie bindings." (should (equal (when-let* ((a nil)) - (list a b c) "no") nil)) (should (equal (when-let* ((a nil) (b 2) (c 3)) - (list a b c) "no") nil)) (should (equal (when-let* ((a 1) (b nil) (c 3)) - (list a b c) "no") nil)) (should (equal (when-let* ((a 1) (b 2) (c nil)) - (list a b c) "no") nil)) (should (equal (let (z) (when-let* (z (a 1) (b 2) (c 3)) - (list a b c) "no")) nil)) (should (equal (let (d) (when-let* ((a 1) (b 2) (c 3) d) - (list a b c) "no")) nil))) diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index cacdef9cb42..69ef5b596be 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -53,7 +53,6 @@ ;; ==== constants-bug-25316 ==== "Testcover doesn't splotch constants." -:expected-result :failed ;; ==== (defconst testcover-testcase-const "apples") (defun testcover-testcase-zero () 0) @@ -76,7 +75,6 @@ ;; ==== customize-defcustom-bug-25326 ==== "Testcover doesn't prevent testing of defcustom values." -:expected-result :failed ;; ==== (defgroup testcover-testcase nil "Test case for testcover" @@ -135,7 +133,6 @@ ;; ==== 1-value-symbol-bug-25316 ==== "Wrapping a form with 1value prevents splotching." -:expected-result :failed ;; ==== (defun testcover-testcase-always-zero (num) (- num%%% num%%%)%%%) @@ -229,8 +226,7 @@ (should-not (testcover-testcase-cc nil)) ;; ==== quotes-within-backquotes-bug-25316 ==== -"Forms to instrument are found within quotes within backquotes." -:expected-result :failed +"Forms to analyze are found within quotes within backquotes." ;; ==== (defun testcover-testcase-make-list () (list 'defun 'defvar)) @@ -296,7 +292,6 @@ ;; ==== backquote-1value-bug-24509 ==== "Commas within backquotes are recognized as non-1value." -:expected-result :failed ;; ==== (defmacro testcover-testcase-lambda (&rest body) `(lambda () ,@body)) @@ -320,7 +315,6 @@ ;; ==== pcase-bug-24688 ==== "Testcover copes with condition-case within backquoted list." -:expected-result :failed ;; ==== (defun testcover-testcase-pcase (form) (pcase form%%% @@ -335,7 +329,6 @@ ;; ==== defun-in-backquote-bug-11307-and-24743 ==== "Testcover handles defun forms within backquoted list." -:expected-result :failed ;; ==== (defmacro testcover-testcase-defun (name &rest body) (declare (debug (symbolp def-body))) @@ -348,7 +341,6 @@ ;; ==== closure-1value-bug ==== "Testcover does not mark closures as 1value." -:expected-result :failed ;; ==== ;; -*- lexical-binding:t -*- (setq testcover-testcase-foo nil) @@ -365,7 +357,6 @@ ;; ==== by-value-vs-by-reference-bug-25351 ==== "An object created by a 1value expression may be modified by other code." -:expected-result :failed ;; ==== (defun testcover-testcase-ab () (list 'a 'b)) @@ -386,7 +377,7 @@ (should-error (testcover-testcase-thing 3)) ;; ==== dotted-backquote ==== -"Testcover correctly instruments dotted backquoted lists." +"Testcover can analyze code inside dotted backquoted lists." ;; ==== (defun testcover-testcase-dotted-bq (flag extras) (let* ((bq @@ -396,9 +387,16 @@ (should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e)))) (should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e)))) +;; ==== quoted-backquote ==== +"Testcover correctly handles the quoted backquote symbol." +;; ==== +(defun testcover-testcase-special-symbols () + (list '\` '\, '\,@)) + +(should (equal '(\` \, \,@) (testcover-testcase-special-symbols))) + ;; ==== backquoted-vector-bug-25316 ==== -"Testcover reinstruments within backquoted vectors." -:expected-result :failed +"Testcover can analyze code within backquoted vectors." ;; ==== (defun testcover-testcase-vec (a b c) `[,a%%% ,(list b%%% c%%%)%%%]%%%) @@ -413,9 +411,15 @@ (should (equal '([[4 5] 6]) (testcover-testcase-vec-in-list 4 5 6))) (should (equal '([100]) (testcover-testcase-vec-arg 100))) +;; ==== dotted-list-in-vector-bug-30909 ==== +"Testcover can analyze dotted pairs within vectors." +;; ==== +(defun testcover-testcase-vectors-with-dotted-pairs () + (equal [(1 . "x")] [(1 2 . "y")])%%%) +(should-not (testcover-testcase-vectors-with-dotted-pairs)) + ;; ==== vector-in-macro-spec-bug-25316 ==== -"Testcover reinstruments within vectors." -:expected-result :failed +"Testcover can analyze code inside vectors." ;; ==== (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) @@ -435,7 +439,6 @@ ;; ==== mapcar-is-not-compose ==== "Mapcar with 1value arguments is not 1value." -:expected-result :failed ;; ==== (defvar testcover-testcase-num 0) (defun testcover-testcase-add-num (n) @@ -450,10 +453,10 @@ ;; ==== function-with-edebug-spec-bug-25316 ==== "Functions can have edebug specs too. -See c-make-font-lock-search-function for an example in the Emacs -sources. The other issue is that it's ok to use quote in an -edebug spec, so testcover needs to cope with that." -:expected-result :failed +See `c-make-font-lock-search-function' for an example in the +Emacs sources. `c-make-font-lock-search-function''s Edebug spec +also contains a quote. See comment in `testcover-analyze-coverage' +regarding the odd-looking coverage result for the quoted form." ;; ==== (defun testcover-testcase-make-function (forms) `(lambda (flag) (if flag 0 ,@forms%%%))%%%) @@ -462,7 +465,7 @@ edebug spec, so testcover needs to cope with that." (("quote" (&rest def-form)))) (defun testcover-testcase-thing () - (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%) + (testcover-testcase-make-function '(!!!(+ 1 !!!(+ 2 !!!(+ 3 !!!(+ 4 5)%%%)%%%)%%%)%%%))%%%) (defun testcover-testcase-use-thing () (funcall (testcover-testcase-thing)%%% nil)%%%) @@ -470,7 +473,7 @@ edebug spec, so testcover needs to cope with that." (should (equal (testcover-testcase-use-thing) 15)) ;; ==== backquoted-dotted-alist ==== -"Testcover can instrument a dotted alist constructed with backquote." +"Testcover can analyze a dotted alist constructed with backquote." ;; ==== (defun testcover-testcase-make-alist (expr entries) `((0 . ,expr%%%) . ,entries%%%)%%%) @@ -494,10 +497,18 @@ edebug spec, so testcover needs to cope with that." "Testcover captures and ignores circular list errors." ;; ==== (defun testcover-testcase-cyc1 (a) - (let ((ls (make-list 10 a%%%))) - (nconc ls ls) - ls)) + (let ((ls (make-list 10 a%%%)%%%)) + (nconc ls%%% ls%%%) + ls)) ; The lack of a mark here is due to an ignored circular list error. (testcover-testcase-cyc1 1) (testcover-testcase-cyc1 1) +(defun testcover-testcase-cyc2 (a b) + (let ((ls1 (make-list 10 a%%%)%%%) + (ls2 (make-list 10 b))) + (nconc ls2 ls2) + (nconc ls1%%% ls2) + ls1)) +(testcover-testcase-cyc2 1 2) +(testcover-testcase-cyc2 1 4) ;; testcases.el ends here. diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index be48aa443b6..6c76421d38b 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -124,14 +124,12 @@ arguments for `testcover-start'." (save-current-buffer (set-buffer (find-file-noselect tempfile)) ;; Fail the test if the debugger tries to become active, - ;; which will happen if Testcover's reinstrumentation - ;; leaves an edebug-enter in the code. This will also - ;; prevent debugging these tests using Edebug. - (cl-letf (((symbol-function #'edebug-enter) + ;; which can happen if Testcover fails to attach itself + ;; correctly. Note that this will prevent debugging + ;; these tests using Edebug. + (cl-letf (((symbol-function #'edebug-default-enter) (lambda (&rest _args) - (ert-fail - (concat "Debugger invoked during test run " - "(possible edebug-enter not replaced)"))))) + (ert-fail "Debugger invoked during test run")))) (dolist (byte-compile '(t nil)) (testcover-tests-unmarkup-region (point-min) (point-max)) (unwind-protect diff --git a/test/lisp/emacs-lisp/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el new file mode 100644 index 00000000000..5ea6b5372e1 --- /dev/null +++ b/test/lisp/emacs-lisp/text-property-search-tests.el @@ -0,0 +1,113 @@ +;;; text-property-search-tests.el --- Testing text-property-search + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: + +;; This program 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. + +;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'text-property-search) +(require 'cl-lib) + +(defun text-property-setup () + (insert "This is " + (propertize "bold1" 'face 'bold) + " and this is " + (propertize "italic1" 'face 'italic) + (propertize "bold2" 'face 'bold) + (propertize "italic2" 'face 'italic) + " at the end") + (goto-char (point-min))) + +(defmacro with-test (form result &optional point) + `(with-temp-buffer + (text-property-setup) + (when ,point + (goto-char ,point)) + (should + (equal + (cl-loop for match = ,form + while match + collect (buffer-substring (prop-match-beginning match) + (prop-match-end match))) + ,result)))) + +(ert-deftest text-property-search-forward-bold-t () + (with-test (text-property-search-forward 'face 'bold t) + '("bold1" "bold2"))) + +(ert-deftest text-property-search-forward-bold-nil () + (with-test (text-property-search-forward 'face 'bold nil) + '("This is " " and this is italic1" "italic2 at the end"))) + +(ert-deftest text-property-search-forward-nil-t () + (with-test (text-property-search-forward 'face nil t) + '("This is " " and this is " " at the end"))) + +(ert-deftest text-property-search-forward-nil-nil () + (with-test (text-property-search-forward 'face nil nil) + '("bold1" "italic1" "bold2" "italic2"))) + +(ert-deftest text-property-search-forward-partial-bold-t () + (with-test (text-property-search-forward 'face 'bold t) + '("old1" "bold2") + 10)) + +(ert-deftest text-property-search-forward-partial-non-current-bold-t () + (with-test (text-property-search-forward 'face 'bold t t) + '("bold2") + 10)) + + +(ert-deftest text-property-search-backward-bold-t () + (with-test (text-property-search-backward 'face 'bold t) + '("bold2" "bold1") + (point-max))) + +(ert-deftest text-property-search-backward-bold-nil () + (with-test (text-property-search-backward 'face 'bold nil) + '( "italic2 at the end" " and this is italic1" "This is ") + (point-max))) + +(ert-deftest text-property-search-backward-nil-t () + (with-test (text-property-search-backward 'face nil t) + '(" at the end" " and this is " "This is ") + (point-max))) + +(ert-deftest text-property-search-backward-nil-nil () + (with-test (text-property-search-backward 'face nil nil) + '("italic2" "bold2" "italic1" "bold1") + (point-max))) + +(ert-deftest text-property-search-backward-partial-bold-t () + (with-test (text-property-search-backward 'face 'bold t) + '("b" "bold1") + 35)) + +(ert-deftest text-property-search-backward-partial-non-current-bold-t () + (with-test (text-property-search-backward 'face 'bold t t) + '("bold1") + 35)) + +(provide 'text-property-search-tests) + +;;; text-property-search-tests.el ends here diff --git a/test/lisp/emacs-lisp/thunk-tests.el b/test/lisp/emacs-lisp/thunk-tests.el index 4cc19f90d6c..b24e8d1fdb7 100644 --- a/test/lisp/emacs-lisp/thunk-tests.el +++ b/test/lisp/emacs-lisp/thunk-tests.el @@ -51,5 +51,55 @@ (thunk-force thunk) (should (= x 1)))) + + +;; thunk-let tests + +(ert-deftest thunk-let-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let ((x 1) (y 2)) (+ x y)) 3))) + +(ert-deftest thunk-let*-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let* ((x 1) (y (+ 1 x))) (+ x y)) 3))) + +(ert-deftest thunk-let-bound-vars-cant-be-set-test () + "Test whether setting a `thunk-let' bound variable fails." + (should-error + (eval '(thunk-let ((x 1)) (let ((y 7)) (setq x (+ x y)) (* 10 x))) t))) + +(ert-deftest thunk-let-laziness-test () + "Test laziness of `thunk-let'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil)) + (thunk-let ((x (progn (setq x-evalled t) (+ 1 2))) + (y (progn (setq y-evalled t) (+ 3 4)))) + (let ((evalled-y y)) + (list x-evalled y-evalled evalled-y)))) + (list nil t 7)))) + +(ert-deftest thunk-let*-laziness-test () + "Test laziness of `thunk-let*'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil) + (z-evalled nil) + (a-evalled nil)) + (thunk-let* ((x (progn (setq x-evalled t) (+ 1 1))) + (y (progn (setq y-evalled t) (+ x 1))) + (z (progn (setq z-evalled t) (+ y 1))) + (a (progn (setq a-evalled t) (+ z 1)))) + (let ((evalled-z z)) + (list x-evalled y-evalled z-evalled a-evalled evalled-z)))) + (list t t t nil 4)))) + +(ert-deftest thunk-let-bad-binding-test () + "Test whether a bad binding causes an error when expanding." + (should-error (macroexpand '(thunk-let ((x 1 1)) x))) + (should-error (macroexpand '(thunk-let (27) x))) + (should-error (macroexpand '(thunk-let x x)))) + + (provide 'thunk-tests) ;;; thunk-tests.el ends here |