diff options
Diffstat (limited to 'test/lisp/emacs-lisp')
54 files changed, 3103 insertions, 893 deletions
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el index 6f099fff173..b08695a22bb 100644 --- a/test/lisp/emacs-lisp/backtrace-tests.el +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -49,7 +49,7 @@ (setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index)))) (backtrace-print)))) - (eval backtrace-tests--uncompiled-functions)) + (eval backtrace-tests--uncompiled-functions t)) (defun backtrace-tests--backtrace-lines () (if debugger-stack-frame-as-list 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-resources/warn-wide-docstring-ignore-substitutions.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el new file mode 100644 index 00000000000..37cfe463bfe --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el @@ -0,0 +1,17 @@ +;;; -*- lexical-binding: t -*- +(defalias 'foo #'ignore + "None of this should be considered too wide. + +; this should be treated as 60 characters - no warning +\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window] + +; 64 * 'x' does not warn +\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x' + +; keymaps are just ignored +\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map> + +\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map} + +bar baz foo bar baz foo bar baz foo bar baz foo bar baz foo bar +") diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a97473e7de4..a246c25e24f 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -640,6 +640,58 @@ inner loops respectively." (f (list (lambda (x) (setq a x))))) (funcall (car f) 3) (list a b)) + + (cond) + (mapcar (lambda (x) (cond ((= x 0)))) '(0 1)) + + ;; These expressions give different results in lexbind and dynbind modes, + ;; but in each the compiler and interpreter should agree! + ;; (They look much the same but come in pairs exercising both the + ;; `let' and `let*' paths.) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (let ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (let* ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (setq x (list x x)) + (let ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (setq x (list x x)) + (let* ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let ((x 'a)) + (list x (funcall g) (funcall h))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let* ((x 'a)) + (list x (funcall g) (funcall h))))))) + (funcall (funcall f 'b))) + + ;; Test constant-propagation of access to captured variables. + (let* ((x 2) + (f (lambda () + (let ((y x)) (list y 3 y))))) + (funcall f)) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -690,24 +742,20 @@ byte-compiled. Run with dynamic binding." (defun test-byte-comp-compile-and-load (compile &rest forms) (declare (indent 1)) - (let ((elfile nil) - (elcfile nil)) - (unwind-protect - (progn - (setf elfile (make-temp-file "test-bytecomp" nil ".el")) - (when compile - (setf elcfile (make-temp-file "test-bytecomp" nil ".elc"))) - (with-temp-buffer - (dolist (form forms) - (print form (current-buffer))) - (write-region (point-min) (point-max) elfile nil 'silent)) - (if compile - (let ((byte-compile-dest-file-function - (lambda (e) elcfile))) - (byte-compile-file elfile))) - (load elfile nil 'nomessage)) - (when elfile (delete-file elfile)) - (when elcfile (delete-file elcfile))))) + (ert-with-temp-file elfile + :suffix ".el" + (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)) + (if compile + (let ((byte-compile-dest-file-function + (lambda (e) elcfile))) + (byte-compile-file elfile))) + (load elfile nil 'nomessage)))) (ert-deftest test-byte-comp-macro-expansion () (test-byte-comp-compile-and-load t @@ -810,8 +858,7 @@ byte-compiled. Run with dynamic binding." (byte-compile-file ,(ert-resource-file file)) (ert-info ((buffer-string) :prefix "buffer: ") (,(if reverse 'should-not 'should) - (re-search-forward ,(string-replace " " "[ \n]+" re-warning) - nil t)))))) + (re-search-forward ,re-warning nil t)))))) (bytecomp--define-warning-file-test "error-lexical-var-with-add-hook.el" "add-hook.*lexical var") @@ -904,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") @@ -939,7 +992,7 @@ byte-compiled. Run with dynamic binding." (bytecomp--define-warning-file-test "warn-wide-docstring-defun.el" - "wider than .* characters") + "Warning: docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-defvar.el" @@ -958,6 +1011,10 @@ byte-compiled. Run with dynamic binding." "defvar .foo-bar. docstring wider than .* characters" 'reverse) (bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-substitutions.el" + "defvar .foo-bar. docstring wider than .* characters" 'reverse) + +(bytecomp--define-warning-file-test "warn-wide-docstring-ignore.el" "defvar .foo-bar. docstring wider than .* characters" 'reverse) @@ -1013,10 +1070,9 @@ byte-compiled. Run with dynamic binding." (defmacro bytecomp-tests--with-temp-file (file-name-var &rest body) (declare (indent 1)) (cl-check-type file-name-var symbol) - `(let ((,file-name-var (make-temp-file "emacs"))) + `(ert-with-temp-file ,file-name-var (unwind-protect (progn ,@body) - (delete-file ,file-name-var) (let ((elc (concat ,file-name-var ".elc"))) (if (file-exists-p elc) (delete-file elc)))))) @@ -1178,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 @@ -1202,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) @@ -1243,25 +1306,25 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--not-writable-directory () "Test that byte compilation works if the output directory isn't writable (Bug#44631)." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (should (byte-compile-file input-file)) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (unwind-protect + (progn + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (should (byte-compile-file input-file)) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777))))) (ert-deftest bytecomp-tests--dest-mountpoint () "Test that byte compilation works if the destination file is a @@ -1273,56 +1336,53 @@ mountpoint (Bug#44631)." (skip-unless (not (file-remote-p bwrap))) (skip-unless (file-executable-p emacs)) (skip-unless (not (file-remote-p emacs))) - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (unquoted-file (file-name-unquote output-file)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (should-not (file-remote-p input-file)) - (should-not (file-remote-p output-file)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (with-temp-buffer - (let ((status (call-process - bwrap nil t nil - "--ro-bind" "/" "/" - "--bind" unquoted-file unquoted-file - emacs "--quick" "--batch" "--load=bytecomp" - (format "--eval=%S" - `(setq byte-compile-dest-file-function - (lambda (_) ,output-file) - byte-compile-error-on-warn t)) - "--funcall=batch-byte-compile" input-file))) - (unless (eql status 0) - (ert-fail `((status . ,status) - (output . ,(buffer-string))))))) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive)))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (unquoted-file (file-name-unquote output-file)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (should-not (file-remote-p input-file)) + (should-not (file-remote-p output-file)) + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (unwind-protect + (progn + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (with-temp-buffer + (let ((status (call-process + bwrap nil t nil + "--ro-bind" "/" "/" + "--bind" unquoted-file unquoted-file + emacs "--quick" "--batch" "--load=bytecomp" + (format "--eval=%S" + `(setq byte-compile-dest-file-function + (lambda (_) ,output-file) + byte-compile-error-on-warn t)) + "--funcall=batch-byte-compile" input-file))) + (unless (eql status 0) + (ert-fail `((status . ,status) + (output . ,(buffer-string))))))) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777)))))) (ert-deftest bytecomp-tests--target-file-no-directory () "Check that Bug#45287 is fixed." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((default-directory directory) - (byte-compile-dest-file-function (lambda (_) "test.elc")) - (byte-compile-error-on-warn t)) - (write-region "" nil "test.el" nil nil nil 'excl) - (should (byte-compile-file "test.el")) - (should (file-regular-p "test.elc")) - (should (cl-plusp (file-attribute-size - (file-attributes "test.elc"))))) - (with-demoted-errors "Error cleaning up directory: %s" - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((default-directory directory) + (byte-compile-dest-file-function (lambda (_) "test.elc")) + (byte-compile-error-on-warn t)) + (write-region "" nil "test.el" nil nil nil 'excl) + (should (byte-compile-file "test.el")) + (should (file-regular-p "test.elc")) + (should (cl-plusp (file-attribute-size + (file-attributes "test.elc"))))))) (defun bytecomp-tests--get-vars () (list (ignore-errors (symbol-value 'bytecomp-tests--var1)) @@ -1492,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 edb746cdecf..9904c6a969c 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -23,6 +23,8 @@ (require 'ert) (require 'cl-lib) +(require 'generator) +(require 'bytecomp) (ert-deftest cconv-tests-lambda-:documentation () "Docstring for lambda can be specified with :documentation." @@ -83,9 +85,6 @@ (iter-yield 'cl-iter-defun-result)) (ert-deftest cconv-tests-cl-iter-defun-:documentation () "Docstring for cl-iter-defun can be specified with :documentation." - ;; FIXME: See Bug#28557. - :tags '(:unstable) - :expected-result :failed (should (string= (documentation 'cconv-tests-cl-iter-defun) "cl-iter-defun documentation")) (should (eq (iter-next (cconv-tests-cl-iter-defun)) @@ -96,17 +95,12 @@ (iter-yield 'iter-defun-result)) (ert-deftest cconv-tests-iter-defun-:documentation () "Docstring for iter-defun can be specified with :documentation." - ;; FIXME: See Bug#28557. - :tags '(:unstable) - :expected-result :failed (should (string= (documentation 'cconv-tests-iter-defun) "iter-defun documentation")) (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) (ert-deftest cconv-tests-iter-lambda-:documentation () "Docstring for iter-lambda can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((iter-fun (iter-lambda () (:documentation (concat "iter-lambda" " documentation")) @@ -116,13 +110,11 @@ (ert-deftest cconv-tests-cl-function-:documentation () "Docstring for cl-function can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((fun (cl-function (lambda (&key arg) (:documentation (concat "cl-function" " documentation")) (list arg 'cl-function-result))))) - (should (string= (documentation fun) "cl-function documentation")) + (should (string-match "\\`cl-function documentation$" (documentation fun))) (should (equal (funcall fun :arg t) '(t cl-function-result))))) (ert-deftest cconv-tests-function-:documentation () @@ -142,8 +134,6 @@ (+ 1 n)) (ert-deftest cconv-tests-cl-defgeneric-:documentation () "Docstring for cl-defgeneric can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) (set-text-properties 0 (length descr) nil descr) (should (string-match-p "cl-defgeneric documentation" descr)) @@ -205,5 +195,157 @@ nil 99) 42))) +(defun cconv-tests--intern-all (x) + "Intern all symbols in X." + (cond ((symbolp x) (intern (symbol-name x))) + ((consp x) (cons (cconv-tests--intern-all (car x)) + (cconv-tests--intern-all (cdr x)))) + ;; Assume we don't need to deal with vectors etc. + (t x))) + +(ert-deftest cconv-closure-convert-remap-var () + ;; Verify that we correctly remap shadowed lambda-lifted variables. + + ;; We intern all symbols for ease of comparison; this works because + ;; the `cconv-closure-convert' result should contain no pair of + ;; distinct symbols having the same name. + + ;; Sanity check: captured variable, no lambda-lifting or shadowing: + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () x)))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (internal-get-closed-var 0))))) + + ;; Basic case: + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((f #'(lambda () x))) + (let ((x 'b)) + (list x (funcall f))))))) + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let ((x 'b) + (closed-x x)) + (list x (funcall f closed-x))))))) + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((f #'(lambda () x))) + (let* ((x 'b)) + (list x (funcall f))))))) + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall f closed-x))))))) + + ;; With the lambda-lifted shadowed variable also being captured: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (let ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x)))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (let* ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x)))))))) + ;; With lambda-lifted shadowed variable also being mutably captured: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (setq x x) + (let ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x))))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (setq x x) + (let* ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x))))))))) + ;; Lambda-lifted variable that isn't actually captured where it is shadowed: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((g #'(lambda () x)) + (h #'(lambda () (setq x x)))) + (let ((x 'b)) + (list x (funcall g) (funcall h))))))) + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let ((x 'b) + (closed-x x)) + (list x (funcall g closed-x) (funcall h closed-x)))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((g #'(lambda () x)) + (h #'(lambda () (setq x x)))) + (let* ((x 'b)) + (list x (funcall g) (funcall h))))))) + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall g closed-x) (funcall h closed-x)))))))) + ) + (provide 'cconv-tests) ;;; cconv-tests.el ends here diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el index 42b6a4ccab6..59dfc10163d 100644 --- a/test/lisp/emacs-lisp/check-declare-tests.el +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -28,6 +28,7 @@ (require 'check-declare) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'subr-x)) (ert-deftest check-declare-tests-locate () @@ -36,62 +37,53 @@ (string-prefix-p "ext:" (check-declare-locate "ext:foo" "")))) (ert-deftest check-declare-tests-scan () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(declare-function ring-insert \"ring\" (ring item))" - "(let ((foo 'code)) foo)") - "\n"))) - (let ((res (check-declare-scan file))) - (should (= (length res) 1)) - (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) - (should (string-match-p "ring" fnfile)) - (should (equal "ring-insert" fn)) - (should (equal '(ring item) arglist)) - (should-not fileonly)))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(declare-function ring-insert \"ring\" (ring item))" + "(let ((foo 'code)) foo)") + "\n"))) + (let ((res (check-declare-scan file))) + (should (= (length res) 1)) + (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) + (should (string-match-p "ring" fnfile)) + (should (equal "ring-insert" fn)) + (should (equal '(ring item) arglist)) + (should-not fileonly))))) (ert-deftest check-declare-tests-verify () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring item)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should-not - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring item)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should-not + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item))))))) (ert-deftest check-declare-tests-verify-mismatch () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should - (equal - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))) - '(("foo.el" "ring-insert" "arglist mismatch"))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should + (equal + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))) + '(("foo.el" "ring-insert" "arglist mismatch")))))) (ert-deftest check-declare-tests-sort () (should-not (check-declare-sort '())) diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index b906e8485cd..56b766769ea 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -27,7 +27,7 @@ (require 'edebug) ;; Don't indirectly require `cl-lib' at run-time. -(eval-when-compile (require 'ert)) +(require 'ert) (declare-function ert--should-signal-hook "ert") (declare-function ert--signal-should-execution "ert") (declare-function ert-fail "ert") @@ -200,9 +200,14 @@ (fmakunbound 'cl--generic-1) (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((x t) y) - (list x y (cl-next-method-p))) + (list x y + (with-suppressed-warnings ((obsolete cl-next-method-p)) + (cl-next-method-p)))) (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) - (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method))) + (cl-list* "quatre" + (with-suppressed-warnings ((obsolete cl-next-method-p)) + (cl-next-method-p)) + (cl-call-next-method))) (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil)))) (ert-deftest cl-generic-test-12-context () diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 03b5371f1bf..b19494af746 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -353,13 +353,6 @@ (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) (should-error (cl-fifth "12345") :type 'wrong-type-argument)) -(ert-deftest cl-lib-test-fifth () - (should (null (cl-fifth '()))) - (should (null (cl-fifth '(1 2 3 4)))) - (should (= 5 (cl-fifth '(1 2 3 4 5)))) - (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) - (should-error (cl-fifth "12345") :type 'wrong-type-argument)) - (ert-deftest cl-lib-test-sixth () (should (null (cl-sixth '()))) (should (null (cl-sixth '(1 2 3 4 5)))) @@ -558,4 +551,9 @@ (should cl-old-struct-compat-mode) (cl-old-struct-compat-mode (if saved 1 -1)))) +(ert-deftest cl-constantly () + (should (equal (mapcar (cl-constantly 3) '(a b c d)) + '(3 3 3 3)))) + + ;;; cl-lib-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 17a84d2067a..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) @@ -529,7 +530,7 @@ collection clause." (should-error ;; Use `eval' so the error is signaled when running the test rather than ;; when macroexpanding it. - (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))))) + (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))) t)) ;; Make sure `gv-synthetic-place' isn't macro-expanded before `setf' gets to ;; see its `gv-expander'. (should (equal (let ((l '(0))) @@ -637,17 +638,26 @@ collection clause." (/ 1 (logand n 1)) (arith-error (len3 (cdr xs) (1+ n))) (:success (len3 (cdr xs) (+ n k)))) - n))) + n)) + + ;; Tail calls in `cond'. + (len4 (xs n) + (cond (xs (cond (nil 'nevertrue) + ((len4 (cdr xs) (1+ n))))) + (t n)))) (should (equal (len nil 0) 0)) (should (equal (len2 nil 0) 0)) (should (equal (len3 nil 0) 0)) + (should (equal (len4 nil 0) 0)) (should (equal (len list-42 0) 42)) (should (equal (len2 list-42 0) 42)) (should (equal (len3 list-42 0) 42)) + (should (equal (len4 list-42 0) 42)) ;; Should not bump into stack depth limits. (should (equal (len list-42k 0) 42000)) (should (equal (len2 list-42k 0) 42000)) - (should (equal (len3 list-42k 0) 42000)))) + (should (equal (len3 list-42k 0) 42000)) + (should (equal (len4 list-42k 0) 42000)))) ;; Check that non-recursive functions are handled more efficiently. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) @@ -657,11 +667,64 @@ collection clause." (should (pcase (macroexpand '(cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n))) #'len)) - (`(function (lambda (,_ ,_) . ,_)) t)))) + (`(function (lambda (,_ ,_) . ,_)) t))) + + ;; Verify that there is no tail position inside dynamic variable bindings. + (defvar dyn-var) + (let ((dyn-var 'a)) + (cl-labels ((f (x) (if x + dyn-var + (let ((dyn-var 'b)) + (f dyn-var))))) + (should (equal (f nil) 'b)))) + + ;; Control: same as above but with lexical binding. + (let ((lex-var 'a)) + (cl-labels ((f (x) (if x + lex-var + (let ((lex-var 'b)) + (f lex-var))))) + (should (equal (f nil) 'a))))) (ert-deftest cl-macs--progv () - (should (= (cl-progv '(test test) '(1 2) test) 2)) - (should (equal (cl-progv '(test1 test2) '(1 2) (list test1 test2)) + (defvar cl-macs--test) + (defvar cl-macs--test1) + (defvar cl-macs--test2) + (should (= (cl-progv '(cl-macs--test cl-macs--test) '(1 2) cl-macs--test) 2)) + (should (equal (cl-progv '(cl-macs--test1 cl-macs--test2) '(1 2) + (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/copyright-tests.el b/test/lisp/emacs-lisp/copyright-tests.el index abb0913a0d7..b00d697aa64 100644 --- a/test/lisp/emacs-lisp/copyright-tests.el +++ b/test/lisp/emacs-lisp/copyright-tests.el @@ -72,5 +72,25 @@ (buffer-string)) "Copyright 2021 FSF\nCopyright 2021, 2022 FSF\n"))) +(defmacro with-copyright-fix-years-test (orig result) + `(let ((copyright-year-ranges t)) + (with-temp-buffer + (insert ,orig) + (copyright-fix-years) + (should (equal (buffer-string) ,result))))) + +(defvar copyright-fix-years-tests--data + '((";; Copyright (C) 2008, 2010, 2012" + . ";; Copyright (C) 2008, 2010, 2012") + (";; Copyright (C) 2008, 2009, 2010, 2013, 2014, 2015, 2016, 2018" + . ";; Copyright (C) 2008-2010, 2013-2016, 2018") + (";; Copyright (C) 2008-2010, 2011, 2015, 2016, 2017" + . ";; Copyright (C) 2008-2010, 2011, 2015-2017"))) + +(ert-deftest text-copyright-fix-years () + "Test basics of \\[copyright-fix-years]." + (dolist (test copyright-fix-years-tests--data) + (with-copyright-fix-years-test (car test) (cdr test)))) + (provide 'copyright-tests) ;;; copyright-tests.el ends here diff --git a/test/lisp/emacs-lisp/derived-tests.el b/test/lisp/emacs-lisp/derived-tests.el index dba8f904c78..547b16843d4 100644 --- a/test/lisp/emacs-lisp/derived-tests.el +++ b/test/lisp/emacs-lisp/derived-tests.el @@ -24,13 +24,13 @@ (define-derived-mode derived-tests--parent-mode prog-mode "P" :after-hook (let ((f (let ((x "S")) (lambda () x)))) - (insert (format "AFP=%s " (let ((x "D")) (funcall f))))) + (insert (format "AFP=%s " (let ((x "D")) x (funcall f))))) (insert "PB ")) (define-derived-mode derived-tests--child-mode derived-tests--parent-mode "C" :after-hook (let ((f (let ((x "S")) (lambda () x)))) - (insert (format "AFC=%s " (let ((x "D")) (funcall f))))) + (insert (format "AFC=%s " (let ((x "D")) x (funcall f))))) (insert "CB ")) (ert-deftest derived-tests-after-hook-lexical () @@ -40,4 +40,25 @@ (derived-tests--child-mode) (should (equal (buffer-string) "PB CB MH AFP=S AFC=S "))))) +(declare-function mode-a "derived-tests") +(declare-function mode-b "derived-tests") +(declare-function mode-c "derived-tests") +(ert-deftest test-add-font-lock () + (define-derived-mode mode-a fundamental-mode "mode-a" + (font-lock-add-keywords nil `(("a" 0 'font-lock-keyword-face)))) + (define-derived-mode mode-b mode-a "mode-b" + (font-lock-add-keywords nil `(("b" 0 'font-lock-builtin-face)))) + (define-derived-mode mode-c mode-b "mode-c" + (font-lock-add-keywords nil `(("c" 0 'font-lock-constant-face)))) + + (with-temp-buffer + (mode-c) + (should (equal font-lock-keywords + '(t (("c" 0 'font-lock-constant-face) + ("b" 0 'font-lock-builtin-face) + ("a" 0 'font-lock-keyword-face)) + ("c" (0 'font-lock-constant-face)) + ("b" (0 'font-lock-builtin-face)) + ("a" (0 'font-lock-keyword-face))))))) + ;;; derived-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 4aae2870a3a..008e1e467ba 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -53,22 +53,20 @@ Since `should' failures which happen inside `post-command-hook' will be trapped by the command loop, this preserves them until we get back to the top level.") -(defvar edebug-tests-keymap - (let ((map (make-sparse-keymap))) - (define-key map "@" 'edebug-tests-call-instrumented-func) - (define-key map "C-u" 'universal-argument) - (define-key map "C-p" 'previous-line) - (define-key map "C-n" 'next-line) - (define-key map "C-b" 'backward-char) - (define-key map "C-a" 'move-beginning-of-line) - (define-key map "C-e" 'move-end-of-line) - (define-key map "C-k" 'kill-line) - (define-key map "M-x" 'execute-extended-command) - (define-key map "C-M-x" 'eval-defun) - (define-key map "C-x X b" 'edebug-set-breakpoint) - (define-key map "C-x X w" 'edebug-where) - map) - "Keys used by the keyboard macros in Edebug's tests.") +(defvar-keymap edebug-tests-keymap + :doc "Keys used by the keyboard macros in Edebug's tests." + "@" 'edebug-tests-call-instrumented-func + "C-u" 'universal-argument + "C-p" 'previous-line + "C-n" 'next-line + "C-b" 'backward-char + "C-a" 'move-beginning-of-line + "C-e" 'move-end-of-line + "C-k" 'kill-line + "M-x" 'execute-extended-command + "C-M-x" 'eval-defun + "C-x X b" 'edebug-set-breakpoint + "C-x X w" 'edebug-where) ;;; Macros for defining tests: @@ -107,27 +105,27 @@ back to the top level.") "Set up the environment for an Edebug test BODY, run it, and clean up." (declare (debug (body))) `(edebug-tests-with-default-config - (let ((edebug-tests-failure-in-post-command nil) - (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (edebug-tests-setup-code-file edebug-tests-temp-file) - (ert-with-message-capture - edebug-tests-messages - (unwind-protect - (with-current-buffer (find-file edebug-tests-temp-file) - (read-only-mode) - (setq lexical-binding t) - (eval-buffer) - ,@body - (when edebug-tests-failure-in-post-command - (signal (car edebug-tests-failure-in-post-command) - (cdr edebug-tests-failure-in-post-command)))) - (unload-feature 'edebug-test-code) - (with-current-buffer (find-file-noselect edebug-tests-temp-file) - (set-buffer-modified-p nil)) - (ignore-errors (kill-buffer (find-file-noselect - edebug-tests-temp-file))) - (ignore-errors (delete-file edebug-tests-temp-file))))))) + (ert-with-temp-file edebug-tests-temp-file + :suffix ".el" + (let ((edebug-tests-failure-in-post-command nil) + (find-file-suppress-same-file-warnings t)) + (edebug-tests-setup-code-file edebug-tests-temp-file) + (ert-with-message-capture + edebug-tests-messages + (unwind-protect + (with-current-buffer (find-file edebug-tests-temp-file) + (read-only-mode) + (setq lexical-binding t) + (eval-buffer) + ,@body + (when edebug-tests-failure-in-post-command + (signal (car edebug-tests-failure-in-post-command) + (cdr edebug-tests-failure-in-post-command)))) + (unload-feature 'edebug-test-code) + (with-current-buffer (find-file-noselect edebug-tests-temp-file) + (set-buffer-modified-p nil)) + (ignore-errors (kill-buffer (find-file-noselect + edebug-tests-temp-file))))))))) ;; The following macro and its support functions implement an extension ;; to keyboard macros to allow interleaving of keyboard macro @@ -860,7 +858,8 @@ test and possibly others should be updated." (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)) (insert "`1")) - (edebug-eval-defun nil) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (edebug-eval-defun nil)) ;; `eval-defun' outputs its message to the echo area in a rather ;; funny way, so the "1" and the " (#o1, #x1, ?\C-a)" end up placed ;; there in separate pieces (via `print' rather than via `message'). @@ -870,7 +869,8 @@ test and possibly others should be updated." (setq edebug-initial-mode 'go) ;; In Bug#23651 Edebug would hang reading `1. - (edebug-eval-defun t))) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (edebug-eval-defun t)))) (ert-deftest edebug-tests-trivial-comma () "Edebug can read a trivial comma expression (Bug#23651)." @@ -879,7 +879,8 @@ test and possibly others should be updated." (delete-region (point-min) (point-max)) (insert ",1") (read-only-mode) - (should-error (edebug-eval-defun t)))) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (should-error (edebug-eval-defun t))))) (ert-deftest edebug-tests-circular-read-syntax () "Edebug can instrument code using circular read object syntax (Bug#23660)." @@ -1103,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/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index be627b01012..af19c122b9f 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -55,6 +55,9 @@ ;;; Code: (require 'eieio) +;; FIXME: See Bug#52971. +(with-no-warnings + (require 'eieio-compat)) (require 'ert) (defvar eieio-test-method-order-list nil @@ -85,37 +88,40 @@ (defclass eitest-B-base2 () ()) (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) -(defmethod eitest-F :BEFORE ((_p eitest-B-base1)) - (eieio-test-method-store :BEFORE 'eitest-B-base1)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method) + (obsolete next-method-p)) + (defmethod eitest-F :BEFORE ((_p eitest-B-base1)) + (eieio-test-method-store :BEFORE 'eitest-B-base1)) -(defmethod eitest-F :BEFORE ((_p eitest-B-base2)) - (eieio-test-method-store :BEFORE 'eitest-B-base2)) + (defmethod eitest-F :BEFORE ((_p eitest-B-base2)) + (eieio-test-method-store :BEFORE 'eitest-B-base2)) -(defmethod eitest-F :BEFORE ((_p eitest-B)) - (eieio-test-method-store :BEFORE 'eitest-B)) + (defmethod eitest-F :BEFORE ((_p eitest-B)) + (eieio-test-method-store :BEFORE 'eitest-B)) -(defmethod eitest-F ((_p eitest-B)) - (eieio-test-method-store :PRIMARY 'eitest-B) - (call-next-method)) - -(defmethod eitest-F ((_p eitest-B-base1)) - (eieio-test-method-store :PRIMARY 'eitest-B-base1) - (call-next-method)) + (defmethod eitest-F ((_p eitest-B)) + (eieio-test-method-store :PRIMARY 'eitest-B) + (call-next-method)) -(defmethod eitest-F ((_p eitest-B-base2)) - (eieio-test-method-store :PRIMARY 'eitest-B-base2) - (when (next-method-p) + (defmethod eitest-F ((_p eitest-B-base1)) + (eieio-test-method-store :PRIMARY 'eitest-B-base1) (call-next-method)) - ) -(defmethod eitest-F :AFTER ((_p eitest-B-base1)) - (eieio-test-method-store :AFTER 'eitest-B-base1)) + (defmethod eitest-F ((_p eitest-B-base2)) + (eieio-test-method-store :PRIMARY 'eitest-B-base2) + (when (next-method-p) + (call-next-method))) -(defmethod eitest-F :AFTER ((_p eitest-B-base2)) - (eieio-test-method-store :AFTER 'eitest-B-base2)) + (defmethod eitest-F :AFTER ((_p eitest-B-base1)) + (eieio-test-method-store :AFTER 'eitest-B-base1)) -(defmethod eitest-F :AFTER ((_p eitest-B)) - (eieio-test-method-store :AFTER 'eitest-B)) + (defmethod eitest-F :AFTER ((_p eitest-B-base2)) + (eieio-test-method-store :AFTER 'eitest-B-base2)) + + (defmethod eitest-F :AFTER ((_p eitest-B)) + (eieio-test-method-store :AFTER 'eitest-B))) (ert-deftest eieio-test-method-order-list-3 () (let ((eieio-test-method-order-list nil) @@ -138,9 +144,11 @@ ;;; Test static invocation ;; -(defmethod eitest-H :STATIC ((_class eitest-A)) - "No need to do work in here." - 'moose) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod eitest-H :STATIC ((_class eitest-A)) + "No need to do work in here." + 'moose)) (ert-deftest eieio-test-method-order-list-4 () ;; Both of these situations should succeed. @@ -149,17 +157,19 @@ ;;; Return value from :PRIMARY ;; -(defmethod eitest-I :BEFORE ((_a eitest-A)) - (eieio-test-method-store :BEFORE 'eitest-A) - ":before") +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod eitest-I :BEFORE ((_a eitest-A)) + (eieio-test-method-store :BEFORE 'eitest-A) + ":before") -(defmethod eitest-I :PRIMARY ((_a eitest-A)) - (eieio-test-method-store :PRIMARY 'eitest-A) - ":primary") + (defmethod eitest-I :PRIMARY ((_a eitest-A)) + (eieio-test-method-store :PRIMARY 'eitest-A) + ":primary") -(defmethod eitest-I :AFTER ((_a eitest-A)) - (eieio-test-method-store :AFTER 'eitest-A) - ":after") + (defmethod eitest-I :AFTER ((_a eitest-A)) + (eieio-test-method-store :AFTER 'eitest-A) + ":after")) (ert-deftest eieio-test-method-order-list-5 () (let ((eieio-test-method-order-list nil) @@ -175,16 +185,18 @@ (defclass C-base2 () ()) (defclass C (C-base1 C-base2) ()) -;; Just use the obsolete name once, to make sure it also works. -(defmethod constructor :STATIC ((_p C-base1) &rest _args) - (eieio-test-method-store :STATIC 'C-base1) - (if (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + ;; Just use the obsolete name once, to make sure it also works. + (defmethod constructor :STATIC ((_p C-base1) &rest _args) + (eieio-test-method-store :STATIC 'C-base1) + (if (next-method-p) (call-next-method))) -(defmethod make-instance :STATIC ((_p C-base2) &rest _args) - (eieio-test-method-store :STATIC 'C-base2) - (if (next-method-p) (call-next-method)) - ) + (defmethod make-instance :STATIC ((_p C-base2) &rest _args) + (eieio-test-method-store :STATIC 'C-base2) + (if (next-method-p) (call-next-method)))) (cl-defmethod make-instance ((_p (subclass C)) &rest _args) (eieio-test-method-store :STATIC 'C) @@ -215,29 +227,32 @@ (defclass D-base2 (D-base0) () :method-invocation-order :depth-first) (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) -(defmethod eitest-F ((_p D)) - "D" - (eieio-test-method-store :PRIMARY 'D) - (call-next-method)) - -(defmethod eitest-F ((_p D-base0)) - "D-base0" - (eieio-test-method-store :PRIMARY 'D-base0) - ;; This should have no next - ;; (when (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method) + (obsolete next-method-p)) + (defmethod eitest-F ((_p D)) + "D" + (eieio-test-method-store :PRIMARY 'D) + (call-next-method)) -(defmethod eitest-F ((_p D-base1)) - "D-base1" - (eieio-test-method-store :PRIMARY 'D-base1) - (call-next-method)) + (defmethod eitest-F ((_p D-base0)) + "D-base0" + (eieio-test-method-store :PRIMARY 'D-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) -(defmethod eitest-F ((_p D-base2)) - "D-base2" - (eieio-test-method-store :PRIMARY 'D-base2) - (when (next-method-p) + (defmethod eitest-F ((_p D-base1)) + "D-base1" + (eieio-test-method-store :PRIMARY 'D-base1) (call-next-method)) - ) + + (defmethod eitest-F ((_p D-base2)) + "D-base2" + (eieio-test-method-store :PRIMARY 'D-base2) + (when (next-method-p) + (call-next-method)))) (ert-deftest eieio-test-method-order-list-7 () (let ((eieio-test-method-order-list nil) @@ -258,25 +273,28 @@ (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) -(defmethod eitest-F ((_p E)) - (eieio-test-method-store :PRIMARY 'E) - (call-next-method)) - -(defmethod eitest-F ((_p E-base0)) - (eieio-test-method-store :PRIMARY 'E-base0) - ;; This should have no next - ;; (when (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod eitest-F ((_p E)) + (eieio-test-method-store :PRIMARY 'E) + (call-next-method)) -(defmethod eitest-F ((_p E-base1)) - (eieio-test-method-store :PRIMARY 'E-base1) - (call-next-method)) + (defmethod eitest-F ((_p E-base0)) + (eieio-test-method-store :PRIMARY 'E-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) -(defmethod eitest-F ((_p E-base2)) - (eieio-test-method-store :PRIMARY 'E-base2) - (when (next-method-p) + (defmethod eitest-F ((_p E-base1)) + (eieio-test-method-store :PRIMARY 'E-base1) (call-next-method)) - ) + + (defmethod eitest-F ((_p E-base2)) + (eieio-test-method-store :PRIMARY 'E-base2) + (when (next-method-p) + (call-next-method)))) (ert-deftest eieio-test-method-order-list-8 () (let ((eieio-test-method-order-list nil) @@ -295,24 +313,32 @@ (defclass eitest-Ja () ()) -(defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) - ;(message "+Ja") - ;; FIXME: Using next-method-p in an after-method is invalid! - (when (next-method-p) - (call-next-method)) - ;(message "-Ja") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) + ;;(message "+Ja") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;;(message "-Ja") + )) (defclass eitest-Jb () ()) -(defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) - ;(message "+Jb") - ;; FIXME: Using next-method-p in an after-method is invalid! - (when (next-method-p) - (call-next-method)) - ;(message "-Jb") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) + ;;(message "+Jb") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;;(message "-Jb") + )) (defclass eitest-Jc (eitest-Jb) ()) @@ -320,12 +346,16 @@ (defclass eitest-Jd (eitest-Jc eitest-Ja) ()) -(defmethod initialize-instance ((_this eitest-Jd) &rest _slots) - ;(message "+Jd") - (when (next-method-p) - (call-next-method)) - ;(message "-Jd") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance ((_this eitest-Jd) &rest _slots) + ;;(message "+Jd") + (when (next-method-p) + (call-next-method)) + ;;(message "-Jd") + )) (ert-deftest eieio-test-method-order-list-9 () (should (eitest-Jd))) @@ -345,32 +375,36 @@ (defclass CNM-2 (CNM-1-1 CNM-1-2) ()) -(defmethod CNM-M ((this CNM-0) args) - (push (cons 'CNM-0 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-0 args)))) - -(defmethod CNM-M ((this CNM-1-1) args) - (push (cons 'CNM-1-1 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-1-1 args)))) - -(defmethod CNM-M ((_this CNM-1-2) args) - (push (cons 'CNM-1-2 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method))) - -(defmethod CNM-M ((this CNM-2) args) - (push (cons 'CNM-2 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-2 args)))) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod CNM-M ((this CNM-0) args) + (push (cons 'CNM-0 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-0 args)))) + + (defmethod CNM-M ((this CNM-1-1) args) + (push (cons 'CNM-1-1 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-1-1 args)))) + + (defmethod CNM-M ((_this CNM-1-2) args) + (push (cons 'CNM-1-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method))) + + (defmethod CNM-M ((this CNM-2) args) + (push (cons 'CNM-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-2 args))))) (ert-deftest eieio-test-method-order-list-10 () (let ((eieio-test-call-next-method-arguments nil)) 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 fcd2f2f45a6..e839e1262fa 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -99,7 +99,7 @@ This is usually a symbol that starts with `:'." (defclass persist-simple (eieio-persistent) ((slot1 :initarg :slot1 :type symbol - :initform moose) + :initform 'moose) (slot2 :initarg :slot2 :initform "foo") (slot3 :initform 2)) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index c03b3854e49..9b27d4ab938 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -27,18 +27,26 @@ (require 'ert) (require 'eieio) (require 'eieio-base) +;; FIXME: See Bug#52971. +(with-no-warnings + (require 'eieio-compat)) (require 'eieio-opt) (eval-when-compile (require 'cl-lib)) +;; Silence byte-compiler. +(eval-when-compile + (dolist (slot '(:a :b ooga-booga :derived-value missing-slot)) + (cl-pushnew slot eieio--known-slot-names))) + ;;; Code: ;; Set up some test classes (defclass class-a () ((water :initarg :water - :initform h20 + :initform 'h20 :type symbol :documentation "Detail about water.") - (classslot :initform penguin + (classslot :initform 'penguin :type symbol :documentation "A class allocated slot." :allocation :class) @@ -50,6 +58,9 @@ ) "Class A.") +;; Silence compiler warning about `water' not being a class-allocated slot. +(defclass eieio-tests--dummy () ((water :allocation :class))) + (defclass class-b () ((land :initform "Sc" :type string @@ -61,40 +72,41 @@ :documentation "Detail about amphibian on land and water.")) "Class A and B combined.") -(defclass class-c () - ((slot-1 :initarg :moose - :initform moose - :type symbol - :allocation :instance - :documentation "First slot testing slot arguments." - :custom symbol - :label "Wild Animal" - :group borg - :protection :public) - (slot-2 :initarg :penguin - :initform "penguin" - :type string - :allocation :instance - :documentation "Second slot testing slot arguments." - :custom string - :label "Wild bird" - :group vorlon - :accessor get-slot-2 - :protection :private) - (slot-3 :initarg :emu - :initform emu - :type symbol - :allocation :class - :documentation "Third slot test class allocated accessor" - :custom symbol - :label "Fuzz" - :group tokra - :accessor get-slot-3 - :protection :private) - ) - (:custom-groups (foo)) - "A class for testing slot arguments." - ) +(with-no-warnings ; FIXME: Make more specific. + (defclass class-c () + ((slot-1 :initarg :moose + :initform 'moose + :type symbol + :allocation :instance + :documentation "First slot testing slot arguments." + :custom symbol + :label "Wild Animal" + :group borg + :protection :public) + (slot-2 :initarg :penguin + :initform "penguin" + :type string + :allocation :instance + :documentation "Second slot testing slot arguments." + :custom string + :label "Wild bird" + :group vorlon + :accessor get-slot-2 + :protection :private) + (slot-3 :initarg :emu + :initform 'emu + :type symbol + :allocation :class + :documentation "Third slot test class allocated accessor" + :custom symbol + :label "Fuzz" + :group tokra + :accessor get-slot-3 + :protection :private) + ) + (:custom-groups (foo)) + "A class for testing slot arguments." + )) (defclass class-subc (class-c) ((slot-1 ;; :initform moose - don't override this @@ -132,21 +144,25 @@ ;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil") ;; ))) +;; Silence byte-compiler. +(declare-function eitest-subordinate--eieio-childp nil) +(declare-function class-alloc-initarg--eieio-childp nil) (ert-deftest eieio-test-01-mix-alloc-initarg () ;; Only run this test if the message framework thingy works. - (when (and (message "foo") (string= "foo" (current-message))) + (skip-unless (and (message "foo") (string= "foo" (current-message)))) - ;; Defining this class should generate a warning(!) message that - ;; you should not mix :initarg with class allocated slots. + ;; Defining this class should generate a warning(!) message that + ;; you should not mix :initarg with class allocated slots. + (with-no-warnings ; FIXME: Make more specific. (defclass class-alloc-initarg () ((throwwarning :initarg :throwwarning - :allocation :class)) - "Throw a warning mixing allocation class and an initarg.") + :allocation :class)) + "Throw a warning mixing allocation class and an initarg.")) - ;; Check that message is there - (should (current-message)) - (should (string-match "Class allocated slots do not need :initarg" - (current-message))))) + ;; Check that message is there + (should (current-message)) + (should (string-match "Class allocated slots do not need :initarg" + (current-message)))) (defclass abstract-class () ((some-slot :initarg :some-slot @@ -160,30 +176,33 @@ ;; error (should-error (abstract-class))) -(defgeneric generic1 () "First generic function.") +(with-suppressed-warnings ((obsolete defgeneric)) + (defgeneric generic1 () "First generic function.")) (ert-deftest eieio-test-03-generics () - (defun anormalfunction () "A plain function for error testing." nil) - (should-error - (progn - (defgeneric anormalfunction () - "Attempt to turn it into a generic."))) - - ;; Check that generic-p works - (should (generic-p 'generic1)) - - (defmethod generic1 ((c class-a)) - "Method on generic1." - 'monkey) - - (defmethod generic1 (not-an-object) - "Method generic1 that can take a non-object." - not-an-object) - - (let ((ans-obj (generic1 (class-a))) - (ans-num (generic1 666))) - (should (eq ans-obj 'monkey)) - (should (eq ans-num 666)))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defun anormalfunction () "A plain function for error testing." nil) + (should-error + (progn + (defgeneric anormalfunction () + "Attempt to turn it into a generic."))) + + ;; Check that generic-p works + (should (generic-p 'generic1)) + + (defmethod generic1 ((_c class-a)) + "Method on generic1." + 'monkey) + + (defmethod generic1 (not-an-object) + "Method generic1 that can take a non-object." + not-an-object) + + (let ((ans-obj (generic1 (class-a))) + (ans-num (generic1 666))) + (should (eq ans-obj 'monkey)) + (should (eq ans-num 666))))) (defclass static-method-class () ((some-slot :initform nil @@ -191,12 +210,17 @@ :documentation "A slot.")) :documentation "A class used for testing static methods.") -(defmethod static-method-class-method :STATIC ((c static-method-class) value) - "Test static methods. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod static-method-class-method :STATIC ((c static-method-class) value) + "Test static methods. Argument C is the class bound to this static method." - (if (eieio-object-p c) (setq c (eieio-object-class c))) - (oset-default c some-slot value)) + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot value))) +;; Silence byte-compiler. +(declare-function static-method-class-2 nil) +(declare-function static-method-class-2--eieio-childp nil) (ert-deftest eieio-test-04-static-method () ;; Call static method on a class and see if it worked (static-method-class-method 'static-method-class 'class) @@ -209,11 +233,13 @@ Argument C is the class bound to this static method." () "A second class after the previous for static methods.") - (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) - "Test static methods. + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) + "Test static methods. Argument C is the class bound to this static method." - (if (eieio-object-p c) (setq c (eieio-object-class c))) - (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))) (static-method-class-method 'static-method-class-2 'class) (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class)) @@ -240,64 +266,71 @@ Argument C is the class bound to this static method." (should (make-instance 'class-a :water 'cho)) (should (make-instance 'class-b))) -(defmethod class-cn ((a class-a)) - "Try calling `call-next-method' when there isn't one. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-cn ((_a class-a)) + "Try calling `call-next-method' when there isn't one. Argument A is object of type symbol `class-a'." - (call-next-method)) + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))) -(defmethod no-next-method ((a class-a) &rest args) - "Override signal throwing for variable `class-a'. + (defmethod no-next-method ((_a class-a) &rest _args) + "Override signal throwing for variable `class-a'. Argument A is the object of class variable `class-a'." - 'moose) + 'moose)) (ert-deftest eieio-test-08-call-next-method () ;; Play with call-next-method (should (eq (class-cn eitest-ab) 'moose))) -(defmethod no-applicable-method ((b class-b) method &rest args) - "No need. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod no-applicable-method ((_b class-b) _method &rest _args) + "No need. Argument B is for booger. METHOD is the method that was attempting to be called." - 'moose) + 'moose)) (ert-deftest eieio-test-09-no-applicable-method () ;; Non-existing methods. (should (eq (class-cn eitest-b) 'moose))) -(defmethod class-fun ((a class-a)) - "Fun with class A." - 'moose) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-fun ((_a class-a)) + "Fun with class A." + 'moose) -(defmethod class-fun ((b class-b)) - "Fun with class B." - (error "Class B fun should not be called") - ) + (defmethod class-fun ((_b class-b)) + "Fun with class B." + (error "Class B fun should not be called")) -(defmethod class-fun-foo ((b class-b)) - "Foo Fun with class B." - 'moose) + (defmethod class-fun-foo ((_b class-b)) + "Foo Fun with class B." + 'moose) -(defmethod class-fun2 ((a class-a)) - "More fun with class A." - 'moose) + (defmethod class-fun2 ((_a class-a)) + "More fun with class A." + 'moose) -(defmethod class-fun2 ((b class-b)) - "More fun with class B." - (error "Class B fun2 should not be called") - ) + (defmethod class-fun2 ((_b class-b)) + "More fun with class B." + (error "Class B fun2 should not be called")) -(defmethod class-fun2 ((ab class-ab)) - "More fun with class AB." - (call-next-method)) + (defmethod class-fun2 ((_ab class-ab)) + "More fun with class AB." + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))) -;; How about if B is the only slot? -(defmethod class-fun3 ((b class-b)) - "Even More fun with class B." - 'moose) + ;; How about if B is the only slot? + (defmethod class-fun3 ((_b class-b)) + "Even More fun with class B." + 'moose) -(defmethod class-fun3 ((ab class-ab)) - "Even More fun with class AB." - (call-next-method)) + (defmethod class-fun3 ((_ab class-ab)) + "Even More fun with class AB." + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method)))) (ert-deftest eieio-test-10-multiple-inheritance () ;; play with methods and mi @@ -314,20 +347,22 @@ METHOD is the method that was attempting to be called." (defvar class-fun-value-seq '()) -(defmethod class-fun-value :BEFORE ((a class-a)) - "Return `before', and push `before' in `class-fun-value-seq'." - (push 'before class-fun-value-seq) - 'before) - -(defmethod class-fun-value :PRIMARY ((a class-a)) - "Return `primary', and push `primary' in `class-fun-value-seq'." - (push 'primary class-fun-value-seq) - 'primary) - -(defmethod class-fun-value :AFTER ((a class-a)) - "Return `after', and push `after' in `class-fun-value-seq'." - (push 'after class-fun-value-seq) - 'after) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-fun-value :BEFORE ((_a class-a)) + "Return `before', and push `before' in `class-fun-value-seq'." + (push 'before class-fun-value-seq) + 'before) + + (defmethod class-fun-value :PRIMARY ((_a class-a)) + "Return `primary', and push `primary' in `class-fun-value-seq'." + (push 'primary class-fun-value-seq) + 'primary) + + (defmethod class-fun-value :AFTER ((_a class-a)) + "Return `after', and push `after' in `class-fun-value-seq'." + (push 'after class-fun-value-seq) + 'after)) (ert-deftest eieio-test-12-generic-function-call () ;; Test value of a generic function call @@ -343,20 +378,23 @@ METHOD is the method that was attempting to be called." ;; (ert-deftest eieio-test-13-init-methods () - (defmethod initialize-instance ((a class-a) &rest slots) - "Initialize the slots of class-a." - (call-next-method) - (if (/= (oref a test-tag) 1) - (error "shared-initialize test failed.")) - (oset a test-tag 2)) - - (defmethod shared-initialize ((a class-a) &rest slots) - "Shared initialize method for class-a." - (call-next-method) - (oset a test-tag 1)) - - (let ((ca (class-a))) - (should (= (oref ca test-tag) 2)))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method)) + (defmethod initialize-instance ((a class-a) &rest _slots) + "Initialize the slots of class-a." + (call-next-method) + (if (/= (oref a test-tag) 1) + (error "shared-initialize test failed.")) + (oset a test-tag 2)) + + (defmethod shared-initialize ((a class-a) &rest _slots) + "Shared initialize method for class-a." + (call-next-method) + (oset a test-tag 1)) + + (let ((ca (class-a))) + (should (= (oref ca test-tag) 2))))) ;;; Perform slot testing @@ -368,10 +406,11 @@ METHOD is the method that was attempting to be called." (should (oref eitest-ab amphibian))) (ert-deftest eieio-test-15-slot-missing () - - (defmethod slot-missing ((ab class-ab) &rest foo) - "If a slot in AB is unbound, return something cool. FOO." - 'moose) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-missing ((_ab class-ab) &rest _foo) + "If a slot in AB is unbound, return something cool. FOO." + 'moose)) (should (eq (oref eitest-ab ooga-booga) 'moose)) (should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name)) @@ -391,17 +430,20 @@ METHOD is the method that was attempting to be called." (defclass virtual-slot-class () ((base-value :initarg :base-value)) "Class has real slot :base-value and simulated slot :derived-value.") -(defmethod slot-missing ((vsc virtual-slot-class) - slot-name operation &optional new-value) - "Simulate virtual slot derived-value." - (cond - ((or (eq slot-name :derived-value) - (eq slot-name 'derived-value)) - (with-slots (base-value) vsc - (if (eq operation 'oref) - (+ base-value 1) - (setq base-value (- new-value 1))))) - (t (call-next-method)))) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-missing ((vsc virtual-slot-class) + slot-name operation &optional new-value) + "Simulate virtual slot derived-value." + (cond + ((or (eq slot-name :derived-value) + (eq slot-name 'derived-value)) + (with-slots (base-value) vsc + (if (eq operation 'oref) + (+ base-value 1) + (setq base-value (- new-value 1))))) + (t (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method)))))) (ert-deftest eieio-test-17-virtual-slot () (setq eitest-vsca (virtual-slot-class :base-value 1)) @@ -424,35 +466,37 @@ METHOD is the method that was attempting to be called." (should (= (oref eitest-vscb :derived-value) 5))) (ert-deftest eieio-test-18-slot-unbound () - - (defmethod slot-unbound ((a class-a) &rest foo) - "If a slot in A is unbound, ignore FOO." - 'moose) - - (should (eq (oref eitest-a water) 'moose)) - - ;; Check if oset of unbound works - (oset eitest-a water 'moose) - (should (eq (oref eitest-a water) 'moose)) - - ;; oref/oref-default comparison - (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) - - ;; oset-default -> oref/oref-default comparison - (oset-default (eieio-object-class eitest-a) water 'moose) - (should (eq (oref eitest-a water) (oref-default eitest-a water))) - - ;; After setting 'water to 'moose, make sure a new object has - ;; the right stuff. - (oset-default (eieio-object-class eitest-a) water 'penguin) - (should (eq (oref (class-a) water) 'penguin)) - - ;; Revert the above - (defmethod slot-unbound ((a class-a) &rest foo) - "If a slot in A is unbound, ignore FOO." - ;; Disable the old slot-unbound so we can run this test - ;; more than once - (call-next-method))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-unbound ((_a class-a) &rest _foo) + "If a slot in A is unbound, ignore FOO." + 'moose) + + (should (eq (oref eitest-a water) 'moose)) + + ;; Check if oset of unbound works + (oset eitest-a water 'moose) + (should (eq (oref eitest-a water) 'moose)) + + ;; oref/oref-default comparison + (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; oset-default -> oref/oref-default comparison + (oset-default (eieio-object-class eitest-a) water 'moose) + (should (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; After setting 'water to 'moose, make sure a new object has + ;; the right stuff. + (oset-default (eieio-object-class eitest-a) water 'penguin) + (should (eq (oref (class-a) water) 'penguin)) + + ;; Revert the above + (defmethod slot-unbound ((_a class-a) &rest _foo) + "If a slot in A is unbound, ignore FOO." + ;; Disable the old slot-unbound so we can run this test + ;; more than once + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))))) (ert-deftest eieio-test-19-slot-type-checking () ;; Slot type checking @@ -489,7 +533,7 @@ METHOD is the method that was attempting to be called." (defclass inittest nil ((staticval :initform 1) - (symval :initform eieio-test-permuting-value) + (symval :initform 'eieio-test-permuting-value) (evalval :initform (symbol-value 'eieio-test-permuting-value)) (evalnow :initform (symbol-value 'eieio-test-permuting-value) :allocation :class) @@ -506,8 +550,10 @@ METHOD is the method that was attempting to be called." (should (eq (oref eitest-pvinit evalval) 2)) (should (eq (oref eitest-pvinit evalnow) 1))) +;; Silence byte-compiler. (defvar eitest-tests nil) - +(declare-function eitest-superior nil) +(declare-function eitest-superior--eieio-childp nil) (ert-deftest eieio-test-22-init-forms-dont-match-runnable () ;; Init forms with types that don't match the runnable. (defclass eitest-subordinate nil @@ -515,7 +561,7 @@ METHOD is the method that was attempting to be called." "Test class that will be a calculated value.") (defclass eitest-superior nil - ((sub :initform (eitest-subordinate) + ((sub :initform (funcall #'eitest-subordinate) :type eitest-subordinate)) "A class with an initform that creates a class.") @@ -555,7 +601,10 @@ METHOD is the method that was attempting to be called." (should-not (cl-typep listooa '(list-of class-b))) (should-not (cl-typep listoob '(list-of class-a))))) +;; Silence byte-compiler. (defvar eitest-t1 nil) +(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present nil) +(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present--eieio-childp nil) (ert-deftest eieio-test-25-slot-tests () (setq eitest-t1 (class-c)) ;; Slot initialization @@ -617,12 +666,14 @@ METHOD is the method that was attempting to be called." () "Protection testing baseclass.") -(defmethod prot0-slot-2 ((s2 prot-0)) - "Try to access slot-2 from this class which doesn't have it. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod prot0-slot-2 ((s2 prot-0)) + "Try to access slot-2 from this class which doesn't have it. The object S2 passed in will be of class prot-1, which does have the slot. This could be allowed, and currently is in EIEIO. Needed by the eieio persistent base class." - (oref s2 slot-2)) + (oref s2 slot-2))) (defclass prot-1 (prot-0) ((slot-1 :initarg :slot-1 @@ -640,26 +691,28 @@ Needed by the eieio persistent base class." nil "A class for testing the :protection option.") -(defmethod prot1-slot-2 ((s2 prot-1)) - "Try to access slot-2 in S2." - (oref s2 slot-2)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod prot1-slot-2 ((s2 prot-1)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) -(defmethod prot1-slot-2 ((s2 prot-2)) - "Try to access slot-2 in S2." - (oref s2 slot-2)) + (defmethod prot1-slot-2 ((s2 prot-2)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) -(defmethod prot1-slot-3-only ((s2 prot-1)) - "Try to access slot-3 in S2. + (defmethod prot1-slot-3-only ((s2 prot-1)) + "Try to access slot-3 in S2. Do not override for `prot-2'." - (oref s2 slot-3)) + (oref s2 slot-3)) -(defmethod prot1-slot-3 ((s2 prot-1)) - "Try to access slot-3 in S2." - (oref s2 slot-3)) + (defmethod prot1-slot-3 ((s2 prot-1)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) -(defmethod prot1-slot-3 ((s2 prot-2)) - "Try to access slot-3 in S2." - (oref s2 slot-3)) + (defmethod prot1-slot-3 ((s2 prot-2)) + "Try to access slot-3 in S2." + (oref s2 slot-3))) (defvar eitest-p1 nil) (defvar eitest-p2 nil) @@ -729,7 +782,7 @@ Do not override for `prot-2'." (should (eq (oref eitest-II3 slot3) 'penguin))) (defclass slotattr-base () - ((initform :initform init) + ((initform :initform 'init) (type :type list) (initarg :initarg :initarg) (protection :protection :private) @@ -744,7 +797,7 @@ Do not override for `prot-2'." Subclasses to override slot attributes.") (defclass slotattr-ok (slotattr-base) - ((initform :initform no-init) + ((initform :initform 'no-init) (initarg :initarg :initblarg) (custom :custom string :label "One String" @@ -778,28 +831,29 @@ Subclasses to override slot attributes.") (let ((obj (slotattr-ok))) (should (eq (oref obj initform) 'no-init)))) -(defclass slotattr-class-base () - ((initform :allocation :class - :initform init) - (type :allocation :class - :type list) - (initarg :allocation :class - :initarg :initarg) - (protection :allocation :class - :protection :private) - (custom :allocation :class - :custom (repeat string) - :label "Custom Strings" - :group moose) - (docstring :allocation :class - :documentation - "Replace the doc-string for this property.") - ) - "Baseclass we will attempt to subclass. -Subclasses to override slot attributes.") +(with-no-warnings ; FIXME: Make more specific. + (defclass slotattr-class-base () + ((initform :allocation :class + :initform 'init) + (type :allocation :class + :type list) + (initarg :allocation :class + :initarg :initarg) + (protection :allocation :class + :protection :private) + (custom :allocation :class + :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :allocation :class + :documentation + "Replace the doc-string for this property.") + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.")) (defclass slotattr-class-ok (slotattr-class-base) - ((initform :initform no-init) + ((initform :initform 'no-init) (initarg :initarg :initblarg) (custom :custom string :label "One String" @@ -861,7 +915,7 @@ Subclasses to override slot attributes.") (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))) (defclass IT (eieio-instance-tracker) - ((tracking-symbol :initform IT-list) + ((tracking-symbol :initform 'IT-list) (slot1 :initform 'die)) "Instance Tracker test object.") @@ -914,13 +968,20 @@ Subclasses to override slot attributes.") (defclass eieio--testing () ()) -(defmethod constructor :static ((_x eieio--testing) newname &rest _args) - (list newname 2)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod constructor :static ((_x eieio--testing) newname &rest _args) + (list newname 2))) (ert-deftest eieio-test-37-obsolete-name-in-constructor () ;; FIXME repeated intermittent failures on hydra and elsewhere (bug#24503). :tags '(:unstable) - (should (equal (eieio--testing "toto") '("toto" 2)))) + ;; Disable byte-compiler "Warning: Obsolete name arg "toto" to + ;; constructor eieio--testing". This could be made more specific + ;; with changes to `with-suppressed-warnings', but it's not worth + ;; the hassle for just this one test. + (with-no-warnings + (should (equal (eieio--testing "toto") '("toto" 2))))) (ert-deftest eieio-autoload () "Tests to see whether reftex-auc has been autoloaded" @@ -969,6 +1030,21 @@ Subclasses to override slot attributes.") (should (eieio-instance-inheritor-slot-boundp C :b)) (should-not (eieio-instance-inheritor-slot-boundp C :c)))) +;;;; Interaction with defstruct + +(cl-defstruct eieio-test--struct a b (c nil :read-only t)) + +(ert-deftest eieio-test-defstruct-slot-value () + (let ((x (make-eieio-test--struct :a 'A :b 'B :c 'C))) + (should (eq (eieio-test--struct-a x) + (slot-value x 'a))) + (should (eq (eieio-test--struct-b x) + (slot-value x 'b))) + (should (eq (eieio-test--struct-c x) + (slot-value x 'c))) + (setf (slot-value x 'a) 1) + (should (eq (eieio-test--struct-a x) 1)) + (should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only))) (provide 'eieio-tests) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index e93ec18406c..84c28e11315 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -39,10 +39,11 @@ (defun ert-self-test () "Run ERT's self-tests and make sure they actually ran." (let ((window-configuration (current-window-configuration))) - (let ((ert--test-body-was-run nil)) + (let ((ert--test-body-was-run nil) + (ert--output-buffer-name " *ert self-tests*")) ;; The buffer name chosen here should not compete with the default ;; results buffer name for completion in `switch-to-buffer'. - (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) + (let ((stats (ert-run-tests-interactively "^ert-"))) (cl-assert ert--test-body-was-run) (if (zerop (ert-stats-completed-unexpected stats)) ;; Hide results window only when everything went well. @@ -376,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) @@ -494,6 +498,12 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert-select-tests '(tag b) (list test)) (list test))) (should (equal (ert-select-tests '(tag c) (list test)) '())))) +(ert-deftest ert-test-select-undefined () + (let* ((symbol (make-symbol "ert-not-a-test")) + (data (should-error (ert-select-tests symbol t) + :type 'ert-test-unbound))) + (should (eq (cadr data) symbol)))) + ;;; Tests for utility functions. (ert-deftest ert-test-parse-keys-and-body () @@ -519,17 +529,18 @@ This macro is used to test if macroexpansion in `should' works." :body (lambda () (ert-skip "skip message"))))) (let ((ert-debug-on-error nil)) - (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((buffer-name (generate-new-buffer-name + " *ert-test-run-tests*")) + (ert--output-buffer-name buffer-name) + (messages nil) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test, skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test, skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " @@ -551,6 +562,69 @@ This macro is used to test if macroexpansion in `should' works." (when (get-buffer buffer-name) (kill-buffer buffer-name)))))))) +(ert-deftest ert-test-run-tests-batch () + (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc")))))))) + (long-list (make-list 11 1)) + (failing-test-1 + (make-ert-test :name 'failing-test-1 + :body (lambda () (should (equal complex-list 1))))) + (failing-test-2 + (make-ert-test :name 'failing-test-2 + :body (lambda () (should (equal long-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-print-level 10) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1 ,failing-test-2)))))) + (let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$") + (complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$") + found-long + found-complex) + (cl-loop for msg in (reverse messages) + do + (unless found-long + (setq found-long (string-match long-text msg))) + (unless found-complex + (setq found-complex (string-match complex-text msg)))) + (should found-long) + (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 + :body (lambda () (should (equal complex-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-backtrace-line-length nil) + (ert-batch-print-level 6) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1)))))) + (let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))") + found-frame) + (cl-loop for msg in (reverse messages) + do + (unless found-frame + (setq found-frame (cl-search frame msg :test 'equal)))) + (should found-frame))))) + (ert-deftest ert-test-special-operator-p () (should (ert--special-operator-p 'if)) (should-not (ert--special-operator-p 'car)) @@ -695,49 +769,40 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert--abbreviate-string "bar" 0 t) ""))) (ert-deftest ert-test-explain-equal-string-properties () - (should - (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) - "foo") - '(char 0 "f" - (different-properties-for-key a (different-atoms b nil)) - context-before "" - context-after "oo"))) - (should (equal (ert--explain-equal-including-properties + (should-not (ert--explain-equal-including-properties-rec "foo" "foo")) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)) + '(char 0 "f" (different-properties-for-key c (different-atoms e d)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec #("foo" 1 3 (a b)) #("goo" 0 1 (c d))) '(array-elt 0 (different-atoms (?f "#x66" "?f") (?g "#x67" "?g"))))) - (should - (equal (ert--explain-equal-including-properties - #("foo" 0 1 (a b c d) 1 3 (a b)) - #("foo" 0 1 (c d a b) 1 2 (a foo))) - '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) - context-before "f" context-after "o")))) - -(ert-deftest ert-test-equal-including-properties () - (should (equal-including-properties "foo" "foo")) - (should (ert-equal-including-properties "foo" "foo")) - - (should (equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - (should (ert-equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - - (should (equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - (should (ert-equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - - (should-not (equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - - ;; This is bug 6581. - (should-not (equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t)))) - (should (ert-equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t))))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) (ert-deftest ert-test-stats-set-test-and-result () (let* ((test-1 (make-ert-test :name 'test-1 @@ -804,7 +869,7 @@ This macro is used to test if macroexpansion in `should' works." (ert-deftest ert-test-with-demoted-errors () "Check that ERT correctly handles `with-demoted-errors'." :expected-result :failed ;; FIXME! Bug#11218 - (should-not (with-demoted-errors (error "Foo")))) + (should-not (with-demoted-errors "FOO: %S" (error "Foo")))) (ert-deftest ert-test-fail-inside-should () "Check that `ert-fail' inside `should' works correctly." @@ -820,6 +885,9 @@ This macro is used to test if macroexpansion in `should' works." "Check that `lexical-binding' in `ert-deftest' has the file value." (should (equal lexical-binding t))) +(ert-deftest ert-test-get-explainer () + (should (eq (ert--get-explainer 'string-equal) 'ert--explain-string-equal)) + (should (eq (ert--get-explainer 'string=) 'ert--explain-string-equal))) (provide 'ert-tests) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index afa2105c48d..38698041102 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -90,10 +90,10 @@ "foo baz"))) (ert-deftest ert-propertized-string () - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "a" '(a b) "b" '(c t) "cd") #("abcd" 1 2 (a b) 2 4 (c t)))) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "foo " '(face italic) "bar" " baz" nil " quux") #("foo bar baz quux" 4 11 (face italic))))) @@ -103,23 +103,27 @@ (ert-deftest ert-test-run-tests-interactively-2 () :tags '(:causes-redisplay) - (let* ((passing-test (make-ert-test :name 'passing-test - :body (lambda () (ert-pass)))) - (failing-test (make-ert-test :name 'failing-test - :body (lambda () - (ert-info ((propertize "foo\nbar" - 'a 'b)) - (ert-fail - "failure message"))))) - (skipped-test (make-ert-test :name 'skipped-test - :body (lambda () (ert-skip - "skip message")))) - (ert-debug-on-error nil) - (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((passing-test (make-ert-test + :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test + :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message"))))) + (skipped-test (make-ert-test + :name 'skipped-test + :body (lambda () (ert-skip + "skip message")))) + (ert-debug-on-error nil) + (messages nil) + (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages))) + (ert--output-buffer-name buffer-name)) (cl-flet ((expected-string (with-font-lock-p) (ert-propertized-string "Selector: (member <passing-test> <failing-test> " @@ -152,21 +156,19 @@ "failing-test" nil "\n Info: " '(a b) "foo\n" nil " " '(a b) "bar" - nil "\n (ert-test-failed \"failure message\")\n\n\n" - ))) + nil "\n (ert-test-failed \"failure message\")\n\n\n"))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test ,skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test ,skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " "1 skipped")))) (with-current-buffer buffer-name (font-lock-mode 0) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -175,7 +177,7 @@ ;; pretend we are. (let ((noninteractive nil)) (font-lock-mode 1)) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -271,6 +273,62 @@ desired effect." (cl-loop for x in '(0 1 2 3 4 t) do (should (equal (c x) (lisp x)))))) +(ert-deftest ert-x-tests--with-temp-file-generate-suffix () + (should (equal (ert--with-temp-file-generate-suffix "foo.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-test.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-tests.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-bar-baz.el") + "-foo-bar-baz")) + (should (equal (ert--with-temp-file-generate-suffix "/foo/bar/baz.el") + "-baz"))) + +(ert-deftest ert-x-tests-with-temp-file () + (let (saved) + (ert-with-temp-file fil + (setq saved fil) + (should (file-exists-p fil)) + (should (file-regular-p fil))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/handle-error () + (let (saved) + (ignore-errors + (ert-with-temp-file fil + (setq saved fil) + (error "foo"))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/prefix-and-suffix-kwarg () + (ert-with-temp-file fil + :prefix "foo" + :suffix "bar" + (should (string-match "foo.*bar" fil)))) + +(ert-deftest ert-x-tests-with-temp-file/text-kwarg () + (ert-with-temp-file fil + :text "foobar3" + (let ((buf (find-file-noselect fil))) + (unwind-protect + (with-current-buffer buf + (should (equal (buffer-string) "foobar3"))) + (kill-buffer buf))))) + +(ert-deftest ert-x-tests-with-temp-file/unknown-kwarg-signals-error () + (should-error + (ert-with-temp-file fil :foo "foo" nil))) + +(ert-deftest ert-x-tests-with-temp-directory () + (let (saved) + (ert-with-temp-directory dir + (setq saved dir) + (should (file-exists-p dir)) + (should (file-directory-p dir)) + (should (equal dir (file-name-as-directory dir)))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-directory/text-signals-error () + (should-error + (ert-with-temp-directory dir :text "foo" nil))) (provide 'ert-x-tests) 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/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index 298e7c8d415..b7a21d49b2f 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -74,7 +74,7 @@ identical output." (cps-testcase cps-prog1-b (prog1 1)) (cps-testcase cps-prog1-c (prog2 1 2 3)) (cps-testcase cps-quote (progn 'hello)) -(cps-testcase cps-function (progn #'hello)) +(cps-testcase cps-function (progn #'message)) (cps-testcase cps-and-fail (and 1 nil 2)) (cps-testcase cps-and-succeed (and 1 2 3)) @@ -85,9 +85,9 @@ identical output." (cps-testcase cps-or-empty (or)) (cps-testcase cps-let* (let* ((i 10)) i)) -(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i))) +(cps-testcase cps-let*-shadow-empty (let* ((i 10)) i (let ((i nil)) i))) (cps-testcase cps-let (let ((i 10)) i)) -(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i))) +(cps-testcase cps-let-shadow-empty (let ((i 10)) i (let ((i nil)) i))) (cps-testcase cps-let-novars (let nil 42)) (cps-testcase cps-let*-novars (let* nil 42)) @@ -95,7 +95,7 @@ identical output." (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b)))) (cps-testcase cps-let*-parallel - (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b)))) + (let* ((a 5) (b 6)) a (let* ((a b) (b a)) (list a b)))) (cps-testcase cps-while-dynamic (setq *cps-test-i* 0) @@ -219,7 +219,7 @@ identical output." (should (eql (iter-next it -1) 42)) (should (eql (iter-next it -1) -1)))) -(ert-deftest cps-loop () +(ert-deftest cps-loop-2 () (should (equal (cl-loop for x iter-by (mygenerator 42) collect x) @@ -307,6 +307,7 @@ identical output." (1+ it))))))) -2))) +(defun generator-tests-edebug ()) ; silence byte-compiler (ert-deftest generator-tests-edebug () "Check that Bug#40434 is fixed." (with-temp-buffer diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index 0b1f9d0cf01..0757e3c7aa5 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -21,22 +21,21 @@ (require 'edebug) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'cl-lib)) (cl-defmacro gv-tests--in-temp-dir ((elvar elcvar) (&rest filebody) &rest body) (declare (indent 2)) - `(let ((default-directory (make-temp-file "gv-test" t))) - (unwind-protect - (let ((,elvar "gv-test-deffoo.el") - (,elcvar "gv-test-deffoo.elc")) - (with-temp-file ,elvar - (insert ";; -*- lexical-binding: t; -*-\n") - (dolist (form ',filebody) - (pp form (current-buffer)))) - ,@body) - (delete-directory default-directory t)))) + `(ert-with-temp-directory default-directory + (let ((,elvar "gv-test-deffoo.el") + (,elcvar "gv-test-deffoo.elc")) + (with-temp-file ,elvar + (insert ";; -*- lexical-binding: t; -*-\n") + (dolist (form ',filebody) + (pp form (current-buffer)))) + ,@body))) (ert-deftest gv-define-expander-in-file () (gv-tests--in-temp-dir (el elc) diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el index 042e57e92f9..c4e4feaad30 100644 --- a/test/lisp/emacs-lisp/let-alist-tests.el +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@ -82,7 +82,7 @@ (ert-deftest let-alist-list-to-sexp () "Check that multiple dots are handled correctly." - (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1))))))))) + (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1)))))) t))) (should (equal (let-alist--access-sexp '.foo.bar.baz 'var) '(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var)))))))) (should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz))) diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index 7d14f5545be..901447ecd27 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -213,6 +213,7 @@ (should-error (forward-sexp)))) ;; FIXME: Shouldn't be an error. ;; Test some core Elisp rules. +(defvar c-e-x) (ert-deftest core-elisp-tests-1-defvar-in-let () "Test some core Elisp rules." (with-temp-buffer @@ -235,7 +236,7 @@ (should (or (not mark-active) (mark))))) (ert-deftest core-elisp-tests-3-backquote () - (should (eq 3 (eval ``,,'(+ 1 2))))) + (should (eq 3 (eval ``,,'(+ 1 2) t)))) ;; Test up-list and backward-up-list. (defun lisp-run-up-list-test (fn data start instructions) @@ -324,7 +325,7 @@ start." (declare (indent 1) (debug (def-form body))) (let* ((var-pos nil) (text (with-temp-buffer - (insert (eval contents)) + (insert (eval contents t)) (goto-char (point-min)) (while (re-search-forward elisp-test-point-position-regex nil t) (push (list (intern (match-string-no-properties 1)) diff --git a/test/lisp/emacs-lisp/macroexp-resources/m1.el b/test/lisp/emacs-lisp/macroexp-resources/m1.el index acffe6b8b61..88c51e75261 100644 --- a/test/lisp/emacs-lisp/macroexp-resources/m1.el +++ b/test/lisp/emacs-lisp/macroexp-resources/m1.el @@ -5,23 +5,23 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; - ;;; Code: (defconst macroexp--m1-tests-filename (macroexp-file-name)) diff --git a/test/lisp/emacs-lisp/macroexp-resources/m2.el b/test/lisp/emacs-lisp/macroexp-resources/m2.el index 0bb8d02a135..cebe4cac125 100644 --- a/test/lisp/emacs-lisp/macroexp-resources/m2.el +++ b/test/lisp/emacs-lisp/macroexp-resources/m2.el @@ -5,23 +5,23 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; - ;;; Code: (defconst macroexp--m2-tests-filename (macroexp-file-name)) diff --git a/test/lisp/emacs-lisp/macroexp-resources/vk.el b/test/lisp/emacs-lisp/macroexp-resources/vk.el new file mode 100644 index 00000000000..d9ca33671ef --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/vk.el @@ -0,0 +1,130 @@ +;;; vk.el --- test code for macroexp-tests -*- 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 'macroexp) + +(defmacro vk-variable-kind (var) + (if (macroexp--dynamic-variable-p var) ''dyn ''lex)) + +(defvar vk-a 1) +(defconst vk-b 2) +(defvar vk-c) + +(defun vk-f1 (x) + (defvar vk-u1) + (let ((vk-a 10) + (vk-b 20) + (vk-c 30) + (vk-u1 40) + (y 50)) + (ignore vk-a vk-b vk-c vk-u1 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-c) ; dyn + (vk-variable-kind vk-u1) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y)))) ; lex + +(eval-and-compile + (defvar vk-u2) + (defun vk-f2 (x) + (defvar vk-v2) + (let ((vk-u2 11) + (vk-v2 12) + (y 13)) + (ignore vk-u2 vk-v2 x y) + (list + (vk-variable-kind vk-u2) ; dyn + (vk-variable-kind vk-v2) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(eval-when-compile + (defvar vk-u3) + (defun vk-f3 (x) + (defvar vk-v3) + (let ((vk-a 23) + (vk-b 24) + (vk-u3 25) + (vk-v3 26) + (y 27)) + (ignore vk-a vk-b vk-u3 vk-v3 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-u3) ; dyn + (vk-variable-kind vk-v3) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(defconst vk-val3 (eval-when-compile (vk-f3 0))) + +(defconst vk-f4 '(lambda (x) + (defvar vk-v4) + (let ((vk-v4 31) + (y 32)) + (ignore vk-v4 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v4) ; dyn + (vk-variable-kind x) ; dyn + (vk-variable-kind y))))) ; dyn + +(defconst vk-f5 '(closure (t) (x) + (defvar vk-v5) + (let ((vk-v5 41) + (y 42)) + (ignore vk-v5 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v5) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(defun vk-f6 () + (eval '(progn + (defvar vk-v6) + (let ((vk-v6 51) + (y 52)) + (ignore vk-v6 y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v6) ; dyn + (vk-variable-kind vk-y)))))) ; dyn + +(defun vk-f7 () + (eval '(progn + (defvar vk-v7) + (let ((vk-v7 51) + (y 52)) + (ignore vk-v7 y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v7) ; dyn + (vk-variable-kind vk-y)))) ; lex + t)) + +(provide 'vk) diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el index ee400626a26..4e6bd8b8fcd 100644 --- a/test/lisp/emacs-lisp/macroexp-tests.el +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -5,25 +5,28 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; - ;;; Code: +(require 'macroexp) +(require 'ert-x) + (ert-deftest macroexp--tests-fgrep () (should (equal (macroexp--fgrep '((x) (y)) '([x] z ((u)))) '((x)))) @@ -67,6 +70,58 @@ (should (equal "m1.el" (file-name-nondirectory macroexp--m1-tests-comp-filename))))) +(defun macroexp-tests--run-emacs (&rest args) + "Run Emacs in batch mode with ARGS, return output." + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (with-temp-buffer + (let ((res (apply #'call-process emacs nil t nil + "-Q" "--batch" args)) + (output (buffer-string))) + (unless (equal res 0) + (message "%s" output) + (error "Inferior Emacs exited with status %S" res)) + output)))) + +(defun macroexp-tests--eval-in-subprocess (file expr) + (let ((output (macroexp-tests--run-emacs + "-l" file (format "--eval=(print %S)" expr)))) + (car (read-from-string output)))) + +(defun macroexp-tests--byte-compile-in-subprocess (file) + "Byte-compile FILE using a subprocess to avoid contaminating the lisp state." + (let ((output (macroexp-tests--run-emacs "-f" "batch-byte-compile" file))) + (when output + (message "%s" output)))) + +(ert-deftest macroexp--tests-dynamic-variable-p () + "Test `macroexp--dynamic-variable-p'." + (let* ((vk-el (ert-resource-file "vk.el")) + (vk-elc (concat vk-el "c")) + (expr '(list (vk-f1 0) + (vk-f2 0) + vk-val3 + (funcall vk-f4 0) + (funcall vk-f5 0) + (vk-f6) + (vk-f7)))) + ;; We compile and run the test in separate processes for complete + ;; isolation between test cases. + (should (equal (macroexp-tests--eval-in-subprocess vk-el expr) + '((dyn dyn dyn dyn lex lex) + (dyn dyn lex lex) + (dyn dyn dyn dyn lex lex) + (dyn dyn dyn dyn dyn) + (dyn dyn dyn lex lex) + (dyn dyn dyn dyn) + (dyn dyn dyn lex)))) + (macroexp-tests--byte-compile-in-subprocess vk-el) + (should (equal (macroexp-tests--eval-in-subprocess vk-elc expr) + '((dyn dyn dyn dyn lex lex) + (dyn dyn lex lex) + (dyn dyn dyn dyn lex lex) + (dyn dyn dyn dyn dyn) + (dyn dyn dyn lex lex) + (dyn dyn dyn dyn) + (dyn dyn dyn lex)))))) -(provide 'macroexp-tests) ;;; macroexp-tests.el ends here diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 4fca8b36199..314a1c9e302 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -422,9 +422,6 @@ Evaluate BODY for each created map." (should (map-every-p (lambda (k _v) (zerop k)) map)))) (ert-deftest test-map-into () - ;; This test is unstable in Emacs 28, but the problem has been fixed - ;; in Emacs 29 (bug#46722). - :tags '(:unstable) (let* ((plist '(a 1 b 2)) (alist '((a . 1) (b . 2))) (ht (map-into alist 'hash-table)) @@ -443,9 +440,6 @@ Evaluate BODY for each created map." (ert-deftest test-map-into-hash-test () "Test `map-into' with different hash-table test functions." - ;; This test is unstable in Emacs 28, but the problem has been fixed - ;; in Emacs 29 (bug#46722). - :tags '(:unstable) (should (eq (hash-table-test (map-into () 'hash-table)) #'equal)) (should (eq (hash-table-test (map-into () '(hash-table))) #'eql)) (should (eq (hash-table-test (map-into () '(hash-table :test eq))) #'eq)) @@ -476,9 +470,6 @@ Evaluate BODY for each created map." (ert-deftest test-map-merge () "Test `map-merge'." - ;; This test is unstable in Emacs 28, but the problem has been fixed - ;; in Emacs 29 (bug#46722). - :tags '(:unstable) (should (equal (sort (map-merge 'list '(a 1) '((b . 2) (c . 3)) #s(hash-table data (c 4))) (lambda (x y) (string< (car x) (car y)))) @@ -488,9 +479,6 @@ Evaluate BODY for each created map." (should (equal (map-merge 'plist () '(:a 1)) '(:a 1)))) (ert-deftest test-map-merge-with () - ;; This test is unstable in Emacs 28, but the problem has been fixed - ;; in Emacs 29 (bug#46722). - :tags '(:unstable) (should (equal (sort (map-merge-with 'list #'+ '((1 . 2)) '((1 . 3) (2 . 4)) @@ -503,9 +491,6 @@ Evaluate BODY for each created map." (ert-deftest test-map-merge-empty () "Test merging of empty maps." - ;; This test is unstable in Emacs 28, but the problem has been fixed - ;; in Emacs 29 (bug#46722). - :tags '(:unstable) (should-not (map-merge 'list)) (should-not (map-merge 'alist)) (should-not (map-merge 'plist)) diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el new file mode 100644 index 00000000000..5807c27bd20 --- /dev/null +++ b/test/lisp/emacs-lisp/multisession-tests.el @@ -0,0 +1,207 @@ +;;; multisession-tests.el --- Tests for multisession.el -*- 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/>. + +;;; Commentary: + +;;; Code: + +(require 'multisession) +(require 'ert) +(require 'ert-x) +(require 'cl-lib) + +(declare-function sqlite-close "sqlite.c") + +(ert-deftest multi-test-sqlite-simple () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-storage 'sqlite) + (multisession-directory dir)) + (unwind-protect + (progn + (define-multisession-variable multisession--foo 0 + "" + :synchronized t) + (should (= (multisession-value multisession--foo) 0)) + (cl-incf (multisession-value multisession--foo)) + (should (= (multisession-value multisession--foo) 1)) + (call-process + (concat invocation-directory invocation-name) + nil t nil + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'sqlite) + (user-init-file "/tmp/foo.el")) + (define-multisession-variable multisession--foo 0 + "" + :synchronized t) + (cl-incf (multisession-value multisession--foo)))))) + (should (= (multisession-value multisession--foo) 2))) + (sqlite-close multisession--db) + (setq multisession--db nil))))) + +(ert-deftest multi-test-sqlite-busy () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-directory dir) + (multisession-storage 'sqlite) + proc) + (unwind-protect + (progn + (define-multisession-variable multisession--bar 0 + "" + :synchronized t) + (should (= (multisession-value multisession--bar) 0)) + (cl-incf (multisession-value multisession--bar)) + (should (= (multisession-value multisession--bar) 1)) + (setq proc + (start-process + "other-emacs" + nil + (concat invocation-directory invocation-name) + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'sqlite) + (user-init-file "/tmp/bar.el")) + (define-multisession-variable multisession--bar 0 + "" :synchronized t) + (dotimes (i 100) + (cl-incf (multisession-value multisession--bar)))))))) + (while (process-live-p proc) + (ignore-error 'sqlite-locked-error + (message "multisession--bar %s" (multisession-value multisession--bar)) + ;;(cl-incf (multisession-value multisession--bar)) + ) + (sleep-for 0.1)) + (message "multisession--bar ends up as %s" (multisession-value multisession--bar)) + (should (< (multisession-value multisession--bar) 1003))) + (sqlite-close multisession--db) + (setq multisession--db nil))))) + +(ert-deftest multi-test-files-simple () + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/sfoo.el") + (multisession-storage 'files) + (multisession-directory dir)) + (define-multisession-variable multisession--sfoo 0 + "" + :synchronized t) + (should (= (multisession-value multisession--sfoo) 0)) + (cl-incf (multisession-value multisession--sfoo)) + (should (= (multisession-value multisession--sfoo) 1)) + ;; On Windows and Haiku, we don't have sub-second resolution, so + ;; let some time pass to make the "later" logic work. + (when (memq system-type '(windows-nt haiku)) + (sleep-for 0.6)) + (call-process + (concat invocation-directory invocation-name) + nil t nil + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'files) + (user-init-file "/tmp/sfoo.el")) + (define-multisession-variable multisession--sfoo 0 + "" + :synchronized t) + (cl-incf (multisession-value multisession--sfoo)))))) + (should (= (multisession-value multisession--sfoo) 2))))) + +(ert-deftest multi-test-files-busy () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-storage 'files) + (multisession-directory dir) + proc) + (define-multisession-variable multisession--sbar 0 + "" + :synchronized t) + (should (= (multisession-value multisession--sbar) 0)) + (cl-incf (multisession-value multisession--sbar)) + (should (= (multisession-value multisession--sbar) 1)) + (setq proc + (start-process + "other-emacs" + nil + (concat invocation-directory invocation-name) + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'files) + (user-init-file "/tmp/sbar.el")) + (define-multisession-variable multisession--sbar 0 + "" :synchronized t) + (dotimes (i 100) + (cl-incf (multisession-value multisession--sbar)))))))) + (while (process-live-p proc) + (message "multisession--sbar %s" (multisession-value multisession--sbar)) + ;;(cl-incf (multisession-value multisession--sbar)) + (sleep-for 0.1)) + (message "multisession--sbar ends up as %s" (multisession-value multisession--sbar)) + (should (< (multisession-value multisession--sbar) 200))))) + +(ert-deftest multi-test-files-some-values () + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/sfoo.el") + (multisession-storage 'files) + (multisession-directory dir)) + (define-multisession-variable multisession--foo1 nil) + (should (eq (multisession-value multisession--foo1) nil)) + (setf (multisession-value multisession--foo1) nil) + (should (eq (multisession-value multisession--foo1) nil)) + (setf (multisession-value multisession--foo1) t) + (should (eq (multisession-value multisession--foo1) t)) + + (define-multisession-variable multisession--foo2 t) + (setf (multisession-value multisession--foo2) nil) + (should (eq (multisession-value multisession--foo2) nil)) + (setf (multisession-value multisession--foo2) t) + (should (eq (multisession-value multisession--foo2) t)) + + (define-multisession-variable multisession--foo3 t) + (should-error (setf (multisession-value multisession--foo3) (make-marker))) + + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (define-multisession-variable multisession--foo4 nil) + (setf (multisession-value multisession--foo4) string) + (should (equal (multisession-value multisession--foo4) string)))))) + +;;; multisession-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/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el new file mode 100644 index 00000000000..724f88ec9ea --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el @@ -0,0 +1,12 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defun macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el new file mode 100644 index 00000000000..828968a0576 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el @@ -0,0 +1,21 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 1.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defun macro-builtin-func () + "" + (macro-builtin-1 'a 'b) + (macro-builtin-aux-1 'a 'b)) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el new file mode 100644 index 00000000000..9f257d9d22c --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el @@ -0,0 +1,16 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defmacro macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defmacro macro-builtin-aux-3 ( &rest _) + "Description" + 90) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el new file mode 100644 index 00000000000..5d241c082d0 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el @@ -0,0 +1,30 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 2.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,(cadr (car forms)))) + + +(defun macro-builtin-func () + "" + (list (macro-builtin-1 '1 'b) + (macro-builtin-aux-1 'a 'b))) + +(defmacro macro-builtin-3 (&rest _) + "Description" + 10) + +(defun macro-builtin-10-and-90 () + "" + (list (macro-builtin-3 haha) (macro-builtin-aux-3 hehe))) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 69c14050b96..d7a55998c20 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -115,57 +115,55 @@ &rest body) "Set up temporary locations and variables for testing." (declare (indent 1) (debug (([&rest form]) body))) - `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) - (process-environment (cons (format "HOME=%s" package-test-user-dir) - process-environment)) - (package-user-dir package-test-user-dir) - (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) - (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) - (default-directory package-test-file-dir) - abbreviated-home-dir - package--initialized - package-alist - ,@(if update-news - '(package-update-news-on-upload t) - (list (cl-gensym))) - ,@(if upload-base - '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) - (package-archive-upload-base package-test-archive-upload-base)) - (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil - (let ((buf (get-buffer "*Packages*"))) - (when (buffer-live-p buf) - (kill-buffer buf))) - (unwind-protect - (progn - ,(if basedir `(cd ,basedir)) - (unless (file-directory-p package-user-dir) - (mkdir package-user-dir)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) - ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) - ,@(when install - `((package-initialize) - (package-refresh-contents) - (mapc 'package-install ,install))) - (with-temp-buffer - ,(if file - `(insert-file-contents ,file)) - ,@body))) - - (when ,upload-base - (dolist (f '("archive-contents" - "simple-single-1.3.el" - "simple-single-1.4.el" - "simple-single-readme.txt")) - (ignore-errors - (delete-file - (expand-file-name f package-test-archive-upload-base)))) - (delete-directory package-test-archive-upload-base)) - (when (file-directory-p package-test-user-dir) - (delete-directory package-test-user-dir t)) - - (when (and (boundp 'package-test-archive-upload-base) - (file-directory-p package-test-archive-upload-base)) - (delete-directory package-test-archive-upload-base t))))) + `(ert-with-temp-directory package-test-user-dir + (let* ((process-environment (cons (format "HOME=%s" package-test-user-dir) + process-environment)) + (package-user-dir package-test-user-dir) + (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) + (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) + (default-directory package-test-file-dir) + abbreviated-home-dir + package--initialized + package-alist + ,@(if update-news + '(package-update-news-on-upload t) + (list (cl-gensym))) + ,@(if upload-base + '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) + (package-archive-upload-base package-test-archive-upload-base)) + (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (kill-buffer buf))) + (unwind-protect + (progn + ,(if basedir `(cd ,basedir)) + (unless (file-directory-p package-user-dir) + (mkdir package-user-dir)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) + ,@(when install + `((package-initialize) + (package-refresh-contents) + (mapc 'package-install ,install))) + (with-temp-buffer + ,(if file + `(insert-file-contents ,file)) + ,@body))) + + (when ,upload-base + (dolist (f '("archive-contents" + "simple-single-1.3.el" + "simple-single-1.4.el" + "simple-single-readme.txt")) + (ignore-errors + (delete-file + (expand-file-name f package-test-archive-upload-base)))) + (delete-directory package-test-archive-upload-base)) + + (when (and (boundp 'package-test-archive-upload-base) + (file-directory-p package-test-archive-upload-base)) + (delete-directory package-test-archive-upload-base t)))))) (defmacro with-fake-help-buffer (&rest body) "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." @@ -342,9 +340,13 @@ but with a different end of line convention (bug#48137)." (declare-function macro-problem-func "macro-problem" ()) (declare-function macro-problem-10-and-90 "macro-problem" ()) +(declare-function macro-builtin-func "macro-builtin" ()) +(declare-function macro-builtin-10-and-90 "macro-builtin" ()) (ert-deftest package-test-macro-compilation () - "Install a package which includes a dependency." + "\"Activation has to be done before compilation, so that if we're + upgrading and macros have changed we load the new definitions + before compiling.\" -- package.el" (with-package-test (:basedir (ert-resource-directory)) (package-install-file (expand-file-name "macro-problem-package-1.0/")) (require 'macro-problem) @@ -357,6 +359,32 @@ but with a different end of line convention (bug#48137)." ;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'. (should (equal (macro-problem-10-and-90) '(10 90))))) +(ert-deftest package-test-macro-compilation-gz () + "Built-in's can be superseded as well." + (with-package-test (:basedir (ert-resource-directory)) + (let ((dir (expand-file-name "macro-builtin-package-1.0"))) + (unwind-protect + (let ((load-path load-path)) + (add-to-list 'load-path (directory-file-name dir)) + (byte-recompile-directory dir 0 t) + (mapc (lambda (f) (call-process "gzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (require 'macro-builtin) + (should (member (expand-file-name "macro-builtin-aux.elc" dir) + (mapcar #'car load-history))) + ;; `macro-builtin-func' uses a macro from `macro-aux'. + (should (equal (macro-builtin-func) '(progn a b))) + (package-install-file (expand-file-name "macro-builtin-package-2.0/")) + ;; After upgrading, `macro-builtin-func' depends on a new version + ;; of the macro from `macro-builtin-aux'. + (should (equal (macro-builtin-func) '(1 b))) + ;; `macro-builtin-10-and-90' depends on an entirely new macro from `macro-aux'. + (should (equal (macro-builtin-10-and-90) '(10 90)))) + (mapc #'delete-file + (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'")) + (mapc (lambda (f) (call-process "gunzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\.gz\\'")))))) + (ert-deftest package-test-install-two-dependencies () "Install a package which includes a dependency." (with-package-test () @@ -685,25 +713,23 @@ but with a different end of line convention (bug#48137)." (defvar epg-config--program-alist) ; Silence byte-compiler. (ert-deftest package-test-signed () "Test verifying package signature." - (skip-unless (let ((homedir (make-temp-file "package-test" t))) - (unwind-protect - (let ((process-environment - (cons (concat "HOME=" homedir) - process-environment))) - (require 'epg-config) - (defvar epg-config--program-alist) - (epg-find-configuration - 'OpenPGP nil - ;; By default we require gpg2 2.1+ due to some - ;; practical problems with pinentry. But this - ;; test works fine with 2.0 as well. - (let ((prog-alist (copy-tree epg-config--program-alist))) - (setf (alist-get "gpg2" - (alist-get 'OpenPGP prog-alist) - nil nil #'equal) - "2.0") - prog-alist))) - (delete-directory homedir t)))) + (skip-unless (ert-with-temp-directory homedir + (let ((process-environment + (cons (concat "HOME=" homedir) + process-environment))) + (require 'epg-config) + (defvar epg-config--program-alist) + (epg-find-configuration + 'OpenPGP nil + ;; By default we require gpg2 2.1+ due to some + ;; practical problems with pinentry. But this + ;; test works fine with 2.0 as well. + (let ((prog-alist (copy-tree epg-config--program-alist))) + (setf (alist-get "gpg2" + (alist-get 'OpenPGP prog-alist) + nil nil #'equal) + "2.0") + prog-alist))))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) (package-test-data-dir (ert-resource-file "signed"))) (with-package-test () diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index ea4119bf9a3..80607990808 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -107,8 +107,11 @@ (should (equal (pcase 1 ((cl-type (integer 0 2)) 'integer-0<=n<=2)) 'integer-0<=n<=2)) - (should-error (pcase 1 - ((cl-type notatype) 'integer)))) + (should-error + ;; Avoid error at compile time due to compiler macro. + (eval '(pcase 1 + ((cl-type notatype) 'integer)) + t))) (ert-deftest pcase-tests-setq () (should (equal (let (a b) diff --git a/test/lisp/emacs-lisp/pp-resources/code-formats.erts b/test/lisp/emacs-lisp/pp-resources/code-formats.erts new file mode 100644 index 00000000000..c3e3023cb19 --- /dev/null +++ b/test/lisp/emacs-lisp/pp-resources/code-formats.erts @@ -0,0 +1,142 @@ +Code: + (lambda () + (emacs-lisp-mode) + (let ((code (read (current-buffer)))) + (erase-buffer) + (pp-emacs-lisp-code code) + (untabify (point-min) (point-max)))) + +Name: code-formats1 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats2 + +=-= +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code." + (require 'edebug) + (let ((start (point)) + (standard-output (current-buffer))) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char start) + (indent-sexp))) +=-=-= + + +Name: code-formats3 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot-zot-zot-zot-zot-zot 1 2 (funcall + bar-bar-bar-bar-bar-bar-bar-bar-bar-bar + 2)))) +=-=-= + + +Name: code-formats4 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2) + foo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo + bar zot) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats5 + +=-= +(defgroup pp () + "Pretty printer for Emacs Lisp." + :prefix "pp-" + :group 'lisp) +=-=-= + +Name: code-formats6 + +=-= +(defcustom pp-escape-newlines t + "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean + :group 'pp) +=-=-= + +Name: code-formats7 + +=-= +(defun pp (object &optional stream) + (princ (pp-to-string object) (or stream standard-output))) +=-=-= + + +Name: code-formats8 + +=-= +(defun pp-eval-expression (expression) + "Evaluate EXPRESSION and pretty-print its value. +Also add the value to the front of the list in the variable `values'." + (interactive (list (read--expression "Eval: "))) + (message "Evaluating...") + (let ((result (eval expression lexical-binding))) + (values--store-value result) + (pp-display-expression result "*Pp Eval Output*"))) +=-=-= + +Name: code-formats9 + +=-= +(lambda () + (interactive) + 1) +=-=-= + + +Name: code-formats10 + +=-= +(funcall foo (concat "zot" (if (length> site 0) site + "bar") + "+" + (string-replace " " "+" query))) +=-=-= + + +Name: code-formats11 + +=-= +(lambda () + [(foo bar) (foo bar)]) +=-=-= + +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/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el index d74ef32f9f4..01ac572c537 100644 --- a/test/lisp/emacs-lisp/pp-tests.el +++ b/test/lisp/emacs-lisp/pp-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'pp) +(require 'ert-x) (ert-deftest pp-print-quote () (should (string= (pp-to-string 'quote) "quote")) @@ -32,4 +33,7 @@ (should (string= (pp-to-string '(quotefoo)) "(quotefoo)\n")) (should (string= (pp-to-string '(a b)) "(a b)\n"))) +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "code-formats.erts"))) + ;;; pp-tests.el ends here. diff --git a/test/lisp/emacs-lisp/range-tests.el b/test/lisp/emacs-lisp/range-tests.el new file mode 100644 index 00000000000..660110aa1fb --- /dev/null +++ b/test/lisp/emacs-lisp/range-tests.el @@ -0,0 +1,65 @@ +;;; range-tests.el --- Tests for range.el -*- 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/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'range) +(require 'ert) +(require 'ert-x) + +(ert-deftest ranges () + (should (equal (range-compress-list '(2 3 4 5 9 11 12 13)) + '((2 . 5) 9 (11 . 13)))) + (should (equal (range-uncompress '((2 . 5) 9 (11 . 13))) + '(2 3 4 5 9 11 12 13))) + (should (equal (range-normalize '(1 . 2)) + '((1 . 2)))) + (should (equal (range-difference '((1 . 10)) + '((2 . 7))) + '(1 (8 . 10)))) + (should (equal (range-intersection '((2 . 5) 9 (11 . 13)) + '((5 . 12))) + '(5 9 (11 . 12)))) + (should (equal (range-add-list '((2 . 5) 9 (11 . 13)) + '(10 11 12 15 16 17)) + '((2 . 5) (9 . 10) (11 . 13) (15 . 17)))) + (should (equal (range-remove (copy-tree '((2 . 5) 9 (11 . 13))) + '((5 . 9))) + '((2 . 4) (11 . 13)))) + (should (range-member-p 9 '((2 . 5) 9 (11 . 13)))) + (should (range-member-p 12 '((2 . 5) 9 (11 . 13)))) + (should (equal (range-list-intersection + '(4 5 6 7 8 9) + '((2 . 5) 9 (11 . 13))) + '(4 5 9))) + (should (equal (range-list-difference + '(4 5 6 7 8 9) + '((2 . 5) 9 (11 . 13))) + '(6 7 8))) + (should (equal (range-length '((2 . 5) 9 (11 . 13))) + 8)) + (should (equal (range-concat '((2 . 5) 9 (11 . 13)) + '(6 (12 . 15))) + '((2 . 6) 9 (11 . 15))))) + +;;; range-tests.el ends here diff --git a/test/lisp/emacs-lisp/ring-tests.el b/test/lisp/emacs-lisp/ring-tests.el index 5331af9ca7f..6bbcd94f201 100644 --- a/test/lisp/emacs-lisp/ring-tests.el +++ b/test/lisp/emacs-lisp/ring-tests.el @@ -199,7 +199,7 @@ (should (= (ring-size ring) 3)) (should (equal (ring-elements ring) '(5 4 3))))) -(ert-deftest ring-tests-insert () +(ert-deftest ring-tests-insert-2 () (let ((ring (make-ring 2))) (ring-insert+extend ring :a) (ring-insert+extend ring :b) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index 11499b6b0e7..385b0fe44a5 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -22,14 +22,42 @@ ;;; Commentary: -;; - ;;; Code: (require 'ert) (require 'rmc) +(require 'cl-lib) (eval-when-compile (require 'cl-lib)) +(ert-deftest test-rmc--add-key-description () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t))) + (should (equal (rmc--add-key-description '(?y "yes")) + '(?y . "yes"))) + (should (equal (rmc--add-key-description '(?n "foo")) + '(?n . "n foo"))) + (should (equal (rmc--add-key-description '(?\s "foo bar")) + `(?\s . "SPC foo bar"))))) + +(ert-deftest test-rmc--add-key-description/with-attributes () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t))) + (should (equal-including-properties + (rmc--add-key-description '(?y "yes")) + `(?y . ,(concat (propertize "y" 'face 'read-multiple-choice-face) "es")))) + (should (equal-including-properties + (rmc--add-key-description '(?n "foo")) + `(?n . ,(concat (propertize "n" 'face 'read-multiple-choice-face) " foo")))) + (should (equal-including-properties + (rmc--add-key-description '(?\s "foo bar")) + `(?\s . ,(concat (propertize "SPC" 'face 'read-multiple-choice-face) " foo bar")))))) + +(ert-deftest test-rmc--add-key-description/non-graphical-display () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) nil))) + (should (equal-including-properties + (rmc--add-key-description '(?y "yes")) + '(?y . "[Y]es"))) + (should (equal-including-properties + (rmc--add-key-description '(?n "foo")) + `(?n . ,(concat (propertize "n" 'face 'help-key-binding) " foo")))))) (ert-deftest test-read-multiple-choice () (dolist (char '(?y ?n)) @@ -38,6 +66,26 @@ (should (equal (list char str) (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) +(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"))))) -(provide 'rmc-tests) ;;; rmc-tests.el ends here diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 228c5c1991e..3b22e42df24 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -173,16 +173,18 @@ Evaluate BODY for each created sequence. (should (seq-find #'null '(1 2 3) 'sentinel))) (ert-deftest test-seq-contains () - (with-test-sequences (seq '(3 4 5 6)) - (should (seq-contains seq 3)) - (should-not (seq-contains seq 7))) - (with-test-sequences (seq '()) - (should-not (seq-contains seq 3)) - (should-not (seq-contains seq nil)))) + (with-suppressed-warnings ((obsolete seq-contains)) + (with-test-sequences (seq '(3 4 5 6)) + (should (seq-contains seq 3)) + (should-not (seq-contains seq 7))) + (with-test-sequences (seq '()) + (should-not (seq-contains seq 3)) + (should-not (seq-contains seq nil))))) (ert-deftest test-seq-contains-should-return-the-elt () - (with-test-sequences (seq '(3 4 5 6)) - (should (= 5 (seq-contains seq 5))))) + (with-suppressed-warnings ((obsolete seq-contains)) + (with-test-sequences (seq '(3 4 5 6)) + (should (= 5 (seq-contains seq 5)))))) (ert-deftest test-seq-contains-p () (with-test-sequences (seq '(3 4 5 6)) @@ -255,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)) @@ -273,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)) @@ -404,7 +433,7 @@ Evaluate BODY for each created sequence. (let ((seq '(1 (2 (3 (4)))))) (seq-let (_ (_ (_ (a)))) seq (should (= a 4)))) - (let (seq) + (let ((seq nil)) (seq-let (a b c) seq (should (null a)) (should (null b)) @@ -428,7 +457,7 @@ Evaluate BODY for each created sequence. (seq '(1 (2 (3 (4)))))) (seq-setq (_ (_ (_ (a)))) seq) (should (= a 4))) - (let (seq a b c) + (let ((seq nil) a b c) (seq-setq (a b c) seq) (should (null a)) (should (null b)) @@ -509,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/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el index 1c4125e3010..8515b9fdfb9 100644 --- a/test/lisp/emacs-lisp/shortdoc-tests.el +++ b/test/lisp/emacs-lisp/shortdoc-tests.el @@ -44,6 +44,17 @@ (should (shortdoc-tests--tree-contains expr fun)))) (setq props (cddr props)))))))) +(ert-deftest shortdoc-all-groups-work () + "Test that all defined shortdoc groups display correctly." + (dolist (group (mapcar (lambda (x) (car x)) shortdoc--groups)) + (let ((buf-name (format "*Shortdoc %s*" group)) buf) + (unwind-protect + (progn + (shortdoc-display-group group) + (should (setq buf (get-buffer buf-name)))) + (when buf + (kill-buffer buf)))))) + (provide 'shortdoc-tests) ;;; shortdoc-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 7d5aca7ba4a..99c0e822155 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -169,13 +169,13 @@ "no") "no")) (should (equal - (let (z) + (let ((z nil)) (if-let* (z (a 1) (b 2) (c 3)) "yes" "no")) "no")) (should (equal - (let (d) + (let ((d nil)) (if-let* ((a 1) (b 2) (c 3) d) "yes" "no")) @@ -191,7 +191,7 @@ (ert-deftest subr-x-test-if-let*-and-laziness-is-preserved () "Test `if-let' respects `and' laziness." - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a nil) (b (setq b-called t)) @@ -199,7 +199,7 @@ "yes" (list a-called b-called c-called)) (list nil nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a (setq a-called t)) (b nil) @@ -207,12 +207,12 @@ "yes" (list a-called b-called c-called)) (list t nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a (setq a-called t)) - (b (setq b-called t)) - (c nil) - (d (setq c-called t))) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) "yes" (list a-called b-called c-called)) (list t t nil))))) @@ -329,12 +329,12 @@ "no") nil)) (should (equal - (let (z) + (let ((z nil)) (when-let* (z (a 1) (b 2) (c 3)) "no")) nil)) (should (equal - (let (d) + (let ((d nil)) (when-let* ((a 1) (b 2) (c 3) d) "no")) nil))) @@ -348,7 +348,7 @@ (ert-deftest subr-x-test-when-let*-and-laziness-is-preserved () "Test `when-let' respects `and' laziness." - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a nil) @@ -357,7 +357,7 @@ "yes") (list a-called b-called c-called)) (list nil nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a (setq a-called t)) @@ -366,7 +366,7 @@ "yes") (list a-called b-called c-called)) (list t nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a (setq a-called t)) @@ -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"))) @@ -638,5 +653,118 @@ (should (equal (string-chop-newline "foo\nbar\n") "foo\nbar")) (should (equal (string-chop-newline "foo\nbar") "foo\nbar"))) +(ert-deftest subr-ensure-empty-lines () + (should + (equal + (with-temp-buffer + (insert "foo") + (goto-char (point-min)) + (ensure-empty-lines 2) + (buffer-string)) + "\n\nfoo")) + (should + (equal + (with-temp-buffer + (insert "foo") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n\n\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n") + (ensure-empty-lines 0) + (buffer-string)) + "foo\n"))) + +(ert-deftest subr-x-test-add-display-text-property () + (with-temp-buffer + (insert "Foo bar zot gazonk") + (add-display-text-property 4 8 'height 2.0) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + '((raise 0.5) (height 2.0)))) + (should (equal (get-text-property 9 'display) '(raise 0.5)))) + (with-temp-buffer + (insert "Foo bar zot gazonk") + (put-text-property 4 8 'display [(height 2.0)]) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + [(raise 0.5) (height 2.0)])) + (should (equal (get-text-property 9 'display) '(raise 0.5))))) + +(ert-deftest subr-x-named-let () + (let ((funs ())) + (named-let loop + ((rest '(1 42 3)) + (sum 0)) + (when rest + ;; Here, we make sure that the variables are distinct in every + ;; iteration, since a naive tail-call optimization would tend to end up + ;; with a single `sum' variable being shared by all the closures. + (push (lambda () sum) funs) + ;; Here we add a dummy `sum' variable which shadows the `sum' iteration + ;; variable since a naive tail-call optimization could also trip here + ;; thinking it can `(setq sum ...)' to set the iteration + ;; variable's value. + (let ((sum sum)) + (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))))) + (provide 'subr-x-tests) ;;; subr-x-tests.el ends here diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index 1d5821146c8..46040be1a6c 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -424,7 +424,7 @@ (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) (debug (form (vector &rest form)))) - `(eval (aref ,vec%%% ,arg%%%))%%%) + `(eval (aref ,vec%%% ,arg%%%) t)%%%) (defun testcover-testcase-use-nth-case (choice val) (testcover-testcase-nth-case choice diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 8bb6b6f0150..39cd3175c26 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -45,34 +45,34 @@ testcases.el. This can be used to create test cases if Testcover is working correctly on a code sample. OPTARGS are optional arguments for `testcover-start'." (interactive "r") - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t) - (code (buffer-substring beg end)) - (marked-up-code)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert code)) - (save-current-buffer - (let ((buf (find-file-noselect tempfile))) - (set-buffer buf) - (apply 'testcover-start (cons tempfile optargs)) - (testcover-mark-all buf) - (dolist (overlay (overlays-in (point-min) (point-max))) - (let ((ov-face (overlay-get overlay 'face))) - (goto-char (overlay-end overlay)) - (cond - ((eq ov-face 'testcover-nohits) (insert "!!!")) - ((eq ov-face 'testcover-1value) (insert "%%%")) - (t nil)))) - (setq marked-up-code (buffer-string))) - (set-buffer-modified-p nil))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile))) - - ;; Now replace the original code with the marked up code. - (delete-region beg end) - (insert marked-up-code)))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t) + (code (buffer-substring beg end)) + (marked-up-code)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert code)) + (save-current-buffer + (let ((buf (find-file-noselect tempfile))) + (set-buffer buf) + (apply 'testcover-start (cons tempfile optargs)) + (testcover-mark-all buf) + (dolist (overlay (overlays-in (point-min) (point-max))) + (let ((ov-face (overlay-get overlay 'face))) + (goto-char (overlay-end overlay)) + (cond + ((eq ov-face 'testcover-nohits) (insert "!!!")) + ((eq ov-face 'testcover-1value) (insert "%%%")) + (t nil)))) + (setq marked-up-code (buffer-string))) + (set-buffer-modified-p nil))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))) + + ;; Now replace the original code with the marked up code. + (delete-region beg end) + (insert marked-up-code))))) (eval-and-compile (defun testcover-tests-unmarkup-region (beg end) @@ -99,32 +99,32 @@ arguments for `testcover-start'." (eval-and-compile (defun testcover-tests-run-test-case (marked-up-code) "Test the operation of Testcover on the string MARKED-UP-CODE." - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert marked-up-code)) - ;; Remove the marks and mark the code up again. The original - ;; and recreated versions should match. - (save-current-buffer - (set-buffer (find-file-noselect tempfile)) - ;; Fail the test if the debugger tries to become active, - ;; 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 "Debugger invoked during test run")))) - (dolist (byte-compile '(t nil)) - (testcover-tests-unmarkup-region (point-min) (point-max)) - (unwind-protect - (testcover-tests-markup-region (point-min) (point-max) byte-compile) - (set-buffer-modified-p nil)) - (should (string= marked-up-code - (buffer-string))))))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile)))))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert marked-up-code)) + ;; Remove the marks and mark the code up again. The original + ;; and recreated versions should match. + (save-current-buffer + (set-buffer (find-file-noselect tempfile)) + ;; Fail the test if the debugger tries to become active, + ;; 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 "Debugger invoked during test run")))) + (dolist (byte-compile '(t nil)) + (testcover-tests-unmarkup-region (point-min) (point-max)) + (unwind-protect + (testcover-tests-markup-region (point-min) (point-max) byte-compile) + (set-buffer-modified-p nil)) + (should (string= marked-up-code + (buffer-string))))))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))))))) ;; Convert test case file to ert-defmethod. 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/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el index 1123596113e..4d974cfd9d7 100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -37,7 +37,8 @@ (ert-deftest timer-tests-debug-timer-check () ;; This function exists only if --enable-checking. (skip-unless (fboundp 'debug-timer-check)) - (should (debug-timer-check))) + (when (fboundp 'debug-timer-check) ; silence byte-compiler + (should (debug-timer-check)))) (ert-deftest timer-test-multiple-of-time () (should (time-equal-p 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 |