diff options
Diffstat (limited to 'test/lisp/emacs-lisp')
34 files changed, 1602 insertions, 143 deletions
diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el index 794488edae8..e5899446ee4 100644 --- a/test/lisp/emacs-lisp/backtrace-tests.el +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -226,6 +226,9 @@ "Forms in backtrace frames can be on a single line or on multiple lines." (ert-with-test-buffer (:name "single-multi-line") (let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure. + ;; Make the form long enough so `number' should not + ;; appear on the first line once pretty-printed. + (interactive (region-beginning)) (let ((number (1+ x))) (+ x number)))) (header-string "Test header: ") @@ -280,7 +283,8 @@ line contains the strings \"lambda\" and \"number\"." ;; Verify that the form is now back on one line, ;; and that point is at the same place. (should (string= (backtrace-tests--get-substring - (- (point) 6) (point)) "number")) + (- (point) 6) (point)) + "number")) (should-not (= (point) (pos-bol))) (should (string= (backtrace-tests--get-substring (pos-bol) (1+ (pos-eol))) diff --git a/test/lisp/emacs-lisp/benchmark-tests.el b/test/lisp/emacs-lisp/benchmark-tests.el index 99b5b142c37..7fe3be2157f 100644 --- a/test/lisp/emacs-lisp/benchmark-tests.el +++ b/test/lisp/emacs-lisp/benchmark-tests.el @@ -25,8 +25,8 @@ (ert-deftest benchmark-tests () ;; Avoid fork failures on Cygwin. See bug#62450 and etc/PROBLEMS ;; ("Fork failures in a build with native compilation"). - (skip-unless (not (and (eq system-type 'cygwin) - (featurep 'native-compile)))) + (skip-when (and (eq system-type 'cygwin) + (featurep 'native-compile))) (let (str t-long t-short m) (should (consp (benchmark-run nil (setq m (1+ 0))))) (should (consp (benchmark-run 1 (setq m (1+ 0))))) diff --git a/test/lisp/emacs-lisp/byte-run-tests.el b/test/lisp/emacs-lisp/byte-run-tests.el new file mode 100644 index 00000000000..59ce24ad251 --- /dev/null +++ b/test/lisp/emacs-lisp/byte-run-tests.el @@ -0,0 +1,32 @@ +;;; byte-run-tests.el --- Tests for byte-run.el -*- lexical-binding: t -*- + +;; Copyright (C) 2023 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) + +(ert-deftest make-obsolete () + (should-error (make-obsolete nil 'foo "30.1")) + (should-error (make-obsolete t 'foo "30.1") )) + +(ert-deftest make-obsolete-variable () + (should-error (make-obsolete-variable nil 'foo "30.1")) + (should-error (make-obsolete-variable t 'foo "30.1"))) + +;;; byte-run-tests.el ends here diff --git a/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el index 00ad1947507..1de5cf66b66 100644 --- a/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el +++ b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el @@ -1 +1 @@ -;; -*- no-byte-compile: t; -*- +;; -*- no-byte-compile: t; lexical-binding: t; -*- diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el new file mode 100644 index 00000000000..9369e78ff54 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (make-process :name "ls")) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el new file mode 100644 index 00000000000..4226349afef --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (make-process :name "ls" :command)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el new file mode 100644 index 00000000000..18250f14ee9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (make-process :name "ls" :command "ls" :name "ls")) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el new file mode 100644 index 00000000000..4721035780b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (make-process :name "ls" :command "ls" + :coding-system 'binary)) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 7ae10cdea73..8fbe48bbb9a 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -643,6 +643,16 @@ inner loops respectively." (funcall (car f) 3) (list a b)) + (let ((x (list 1))) + (let ((y x) + (z (setq x (vector x)))) + (list x y z))) + + (let ((x (list 1))) + (let* ((y x) + (z (setq x (vector x)))) + (list x y z))) + (cond) (mapcar (lambda (x) (cond ((= x 0)))) '(0 1)) @@ -677,16 +687,18 @@ inner loops respectively." (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))))))) + (lambda () + (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))))))) + (lambda () + (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. @@ -704,6 +716,90 @@ inner loops respectively." (let ((bytecomp-tests--xx 1)) (set (make-local-variable 'bytecomp-tests--xx) 2) bytecomp-tests--xx) + + ;; Check for-effect optimization of `condition-case' body form. + ;; With `condition-case' in for-effect context: + (let ((x (bytecomp-test-identity ?A)) + (r nil)) + (condition-case e + (characterp x) ; value (:success, var) + (error (setq r 'bad)) + (:success (setq r (list 'good e)))) + r) + (let ((x (bytecomp-test-identity ?B)) + (r nil)) + (condition-case nil + (characterp x) ; for-effect (:success, no var) + (error (setq r 'bad)) + (:success (setq r 'good))) + r) + (let ((x (bytecomp-test-identity ?C)) + (r nil)) + (condition-case e + (characterp x) ; for-effect (no :success, var) + (error (setq r (list 'bad e)))) + r) + (let ((x (bytecomp-test-identity ?D)) + (r nil)) + (condition-case nil + (characterp x) ; for-effect (no :success, no var) + (error (setq r 'bad))) + r) + ;; With `condition-case' in value context: + (let ((x (bytecomp-test-identity ?E))) + (condition-case e + (characterp x) ; for-effect (:success, var) + (error (list 'bad e)) + (:success (list 'good e)))) + (let ((x (bytecomp-test-identity ?F))) + (condition-case nil + (characterp x) ; for-effect (:success, no var) + (error 'bad) + (:success 'good))) + (let ((x (bytecomp-test-identity ?G))) + (condition-case e + (characterp x) ; value (no :success, var) + (error (list 'bad e)))) + (let ((x (bytecomp-test-identity ?H))) + (condition-case nil + (characterp x) ; value (no :success, no var) + (error 'bad))) + + (condition-case nil + (bytecomp-test-identity 3) + (error 'bad) + (:success)) ; empty handler + + ;; `cond' miscompilation bug + (let ((fn (lambda (x) + (let ((y nil)) + (cond ((progn (setq x (1+ x)) (> x 10)) (setq y 'a)) + ((eq x 1) (setq y 'b)) + ((eq x 2) (setq y 'c))) + (list x y))))) + (mapcar fn (bytecomp-test-identity '(0 1 2 3 10 11)))) + + ;; `nconc' nil arg elimination + (nconc (list 1 2 3 4) nil) + (nconc (list 1 2 3 4) nil nil) + (let ((x (cons 1 (cons 2 (cons 3 4))))) + (nconc x nil)) + (let ((x (cons 1 (cons 2 (cons 3 4))))) + (nconc x nil nil)) + (let ((x (cons 1 (cons 2 (cons 3 4))))) + (nconc nil x nil (list 5 6) nil)) + + ;; (+ 0 -0.0) etc + (let ((x (bytecomp-test-identity -0.0))) + (list x (+ x) (+ 0 x) (+ x 0) (+ 1 2 -3 x) (+ 0 x 0))) + + ;; Unary comparisons: keep side-effect, return t + (let ((x 0)) + (list (= (setq x 1)) + x)) + ;; Aristotelian identity optimization + (let ((x (bytecomp-test-identity 1))) + (list (eq x x) (eql x x) (equal x x))) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -752,6 +848,11 @@ byte-compiled. Run with dynamic binding." (should (equal (bytecomp-tests--eval-interpreted form) (bytecomp-tests--eval-compiled form))))))) +(defmacro bytecomp-tests--with-fresh-warnings (&rest body) + `(let ((macroexp--warned ; oh dear + (make-hash-table :test #'equal :weakness 'key))) + ,@body)) + (defun test-byte-comp-compile-and-load (compile &rest forms) (declare (indent 1)) (ert-with-temp-file elfile @@ -766,7 +867,8 @@ byte-compiled. Run with dynamic binding." (if compile (let ((byte-compile-dest-file-function (lambda (e) elcfile))) - (byte-compile-file elfile))) + (bytecomp-tests--with-fresh-warnings + (byte-compile-file elfile)))) (load elfile nil 'nomessage)))) (ert-deftest test-byte-comp-macro-expansion () @@ -833,13 +935,30 @@ byte-compiled. Run with dynamic binding." ;; Should not warn that mt--test2 is not known to be defined. (should-not (re-search-forward "my--test2" nil t)))) -(defmacro bytecomp--with-warning-test (re-warning &rest form) +(defun bytecomp--with-warning-test (re-warning form) (declare (indent 1)) - `(with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create "*Compile-Log*") (let ((inhibit-read-only t)) (erase-buffer)) - (byte-compile ,@form) - (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") - (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning)))))) + (ert-info ((prin1-to-string form) :prefix "form: ") + (let ((text-quoting-style 'grave)) + (bytecomp-tests--with-fresh-warnings + (byte-compile form))) + (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") + (should (re-search-forward + (string-replace " " "[ \n]+" re-warning))))))) + +(defun bytecomp--without-warning-test (form) + (bytecomp--with-warning-test "\\`\\'" form)) + +(ert-deftest bytecomp-warn--ignore () + (bytecomp--with-warning-test "unused" + '(lambda (y) 6)) + (bytecomp--without-warning-test + '(lambda (y) (ignore y) 6)) + (bytecomp--with-warning-test "assq" + '(lambda (x y) (progn (assq x y) 5))) + (bytecomp--without-warning-test + '(lambda (x y) (progn (ignore (assq x y)) 5)))) (ert-deftest bytecomp-warn-wrong-args () (bytecomp--with-warning-test "remq.*3.*2" @@ -863,6 +982,94 @@ byte-compiled. Run with dynamic binding." (bytecomp--with-warning-test "defvar.*foo.*wider than.*characters" `(defvar foo t ,bytecomp-tests--docstring))) +(ert-deftest bytecomp-warn-wide-docstring/cl-defsubst () + (bytecomp--without-warning-test + `(cl-defsubst short-name () + "Do something.")) + (bytecomp--without-warning-test + `(cl-defsubst long-name-with-less-80-characters-but-still-quite-a-bit () + "Do something.")) + (bytecomp--with-warning-test "wider than.*characters" + `(cl-defsubst long-name-with-more-than-80-characters-yes-this-is-a-very-long-name-but-why-not!! () + "Do something."))) + +(ert-deftest bytecomp-warn-wide-docstring/cl-defstruct () + (bytecomp--without-warning-test + `(cl-defstruct short-name + field)) + (bytecomp--without-warning-test + `(cl-defstruct short-name + long-name-with-less-80-characters-but-still-quite-a-bit)) + (bytecomp--without-warning-test + `(cl-defstruct long-name-with-less-80-characters-but-still-quite-a-bit + field)) + (bytecomp--with-warning-test "wider than.*characters" + `(cl-defstruct short-name + long-name-with-more-than-80-characters-yes-this-is-a-very-long-name-but-why-not!!)) + (bytecomp--with-warning-test "wider than.*characters" + `(cl-defstruct long-name-with-more-than-80-characters-yes-this-is-a-very-long-name-but-why-not!! + field))) + +(ert-deftest bytecomp-warn-quoted-condition () + (bytecomp--with-warning-test + "Warning: `condition-case' condition should not be quoted: 'arith-error" + '(condition-case nil + (abc) + ('arith-error "ugh"))) + (bytecomp--with-warning-test + "Warning: `ignore-error' condition argument should not be quoted: 'error" + '(ignore-error 'error (abc)))) + +(ert-deftest bytecomp-warn-dodgy-args-eq () + (dolist (fn '(eq eql)) + (cl-flet ((msg (type arg) + (format + "`%s' called with literal %s that may never match (arg %d)" + fn type arg))) + (bytecomp--with-warning-test (msg "list" 1) `(,fn '(a) 'x)) + (bytecomp--with-warning-test (msg "string" 2) `(,fn 'x "a")) + (bytecomp--with-warning-test (msg "vector" 2) `(,fn 'x [a])) + (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x (lambda () 1))) + (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x #'(lambda () 1))) + (unless (eq fn 'eql) + (bytecomp--with-warning-test (msg "integer" 2) `(,fn 'x #x10000000000)) + (bytecomp--with-warning-test (msg "float" 2) `(,fn 'x 1.0)))))) + +(ert-deftest bytecomp-warn-dodgy-args-memq () + (dolist (fn '(memq memql remq delq assq rassq)) + (cl-labels + ((msg1 (type) + (format + "`%s' called with literal %s that may never match (arg 1)" + fn type)) + (msg2 (type) + (format + "`%s' called with literal %s that may never match (element 2 of arg 2)" + fn type)) + (lst (elt) + (cond ((eq fn 'assq) `((a . 1) (,elt . 2) (c . 3))) + ((eq fn 'rassq) `((1 . a) (2 . ,elt) (3 . c))) + (t `(a ,elt c)))) + (form2 (elt) + `(,fn 'x ',(lst elt)))) + + (bytecomp--with-warning-test (msg1 "list") `(,fn '(a) '(x))) + (bytecomp--with-warning-test (msg1 "string") `(,fn "a" '(x))) + (bytecomp--with-warning-test (msg1 "vector") `(,fn [a] '(x))) + (bytecomp--with-warning-test (msg1 "function") `(,fn (lambda () 1) '(x))) + (bytecomp--with-warning-test (msg1 "function") `(,fn #'(lambda () 1) '(x))) + (unless (eq fn 'memql) + (bytecomp--with-warning-test (msg1 "integer") `(,fn #x10000000000 '(x))) + (bytecomp--with-warning-test (msg1 "float") `(,fn 1.0 '(x)))) + + (bytecomp--with-warning-test (msg2 "list") (form2 '(b))) + (bytecomp--with-warning-test (msg2 "list") (form2 ''b)) + (bytecomp--with-warning-test (msg2 "string") (form2 "b")) + (bytecomp--with-warning-test (msg2 "vector") (form2 [b])) + (unless (eq fn 'memql) + (bytecomp--with-warning-test (msg2 "integer") (form2 #x10000000000)) + (bytecomp--with-warning-test (msg2 "float") (form2 1.0)))))) + (defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse) `(ert-deftest ,(intern (format "bytecomp/%s" file)) () (with-current-buffer (get-buffer-create "*Compile-Log*") @@ -903,7 +1110,7 @@ byte-compiled. Run with dynamic binding." "fails to specify containing group") (bytecomp--define-warning-file-test "warn-defcustom-notype.el" - "fails to specify type") + "missing :type keyword parameter") (bytecomp--define-warning-file-test "warn-defvar-lacks-prefix.el" "var.*foo.*lacks a prefix") @@ -1043,6 +1250,22 @@ byte-compiled. Run with dynamic binding." "nowarn-inline-after-defvar.el" "Lexical argument shadows" 'reverse) +(bytecomp--define-warning-file-test + "warn-make-process-missing-keyword-arg.el" + "called without required keyword argument :command") + +(bytecomp--define-warning-file-test + "warn-make-process-unknown-keyword-arg.el" + "called with unknown keyword argument :coding-system") + +(bytecomp--define-warning-file-test + "warn-make-process-repeated-keyword-arg.el" + "called with repeated keyword argument :name") + +(bytecomp--define-warning-file-test + "warn-make-process-missing-keyword-value.el" + "missing value for keyword argument :command") + ;;;; Macro expansion. @@ -1089,14 +1312,41 @@ byte-compiled. Run with dynamic binding." (let ((elc (concat ,file-name-var ".elc"))) (if (file-exists-p elc) (delete-file elc)))))) +(defun bytecomp-tests--log-from-compilation (source) + "Compile the string SOURCE and return the compilation log output." + (let ((text-quoting-style 'grave) + (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + (with-current-buffer byte-compile-log-buffer + (let ((inhibit-read-only t)) (erase-buffer))) + (bytecomp-tests--with-temp-file el-file + (write-region source nil el-file) + (byte-compile-file el-file)) + (with-current-buffer byte-compile-log-buffer + (buffer-string)))) + +(ert-deftest bytecomp-tests--lexical-binding-cookie () + (cl-flet ((cookie-warning (source) + (string-search + "file has no `lexical-binding' directive on its first line" + (bytecomp-tests--log-from-compilation source)))) + (let ((some-code "(defun my-fun () 12)\n")) + (should-not (cookie-warning + (concat ";;; -*-lexical-binding:t-*-\n" some-code))) + (should-not (cookie-warning + (concat ";;; -*-lexical-binding:nil-*-\n" some-code))) + (should (cookie-warning some-code))))) + (ert-deftest bytecomp-tests--unescaped-char-literals () "Check that byte compiling warns about unescaped character literals (Bug#20852)." (should (boundp 'lread--unescaped-character-literals)) (let ((byte-compile-error-on-warn t) - (byte-compile-debug t)) + (byte-compile-debug t) + (text-quoting-style 'grave)) (bytecomp-tests--with-temp-file source - (write-region "(list ?) ?( ?; ?\" ?[ ?])" nil source) + (write-region (concat ";;; -*-lexical-binding:t-*-\n" + "(list ?) ?( ?; ?\" ?[ ?])") + nil source) (bytecomp-tests--with-temp-file destination (let* ((byte-compile-dest-file-function (lambda (_) destination)) (err (should-error (byte-compile-file source)))) @@ -1108,7 +1358,9 @@ literals (Bug#20852)." "`?\\]' expected!"))))))) ;; But don't warn in subsequent compilations (Bug#36068). (bytecomp-tests--with-temp-file source - (write-region "(list 1 2 3)" nil source) + (write-region (concat ";;; -*-lexical-binding:t-*-\n" + "(list 1 2 3)") + nil source) (bytecomp-tests--with-temp-file destination (let ((byte-compile-dest-file-function (lambda (_) destination))) (should (byte-compile-file source))))))) @@ -1116,6 +1368,7 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." (bytecomp-tests--with-temp-file source + (insert ";;; -*-lexical-binding:t-*-\n") (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1) (function-put 'bytecomp-tests--foo 'bar 2) (defmacro bytecomp-tests--foobar () @@ -1213,6 +1466,7 @@ literals (Bug#20852)." (defun test-suppression (form suppress match) (let ((lexical-binding t) + (text-quoting-style 'grave) (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) ;; Check that we get a warning without suppression. (with-current-buffer byte-compile-log-buffer @@ -1299,8 +1553,8 @@ literals (Bug#20852)." '(defun zot () (mapcar #'list '(1 2 3)) nil) - '((mapcar mapcar)) - "Warning: .mapcar. called for effect") + '((ignored-return-value mapcar)) + "Warning: value from call to `mapcar' is unused; use `mapc' or `dolist' instead") (test-suppression '(defun zot () @@ -1314,7 +1568,101 @@ literals (Bug#20852)." (set-buffer (get-buffer-create "foo")) nil)) '((suspicious set-buffer)) - "Warning: Use .with-current-buffer. rather than")) + "Warning: Use .with-current-buffer. rather than") + + (test-suppression + '(defun zot (x) + (condition-case nil (list x))) + '((suspicious condition-case)) + "Warning: `condition-case' without handlers") + + (test-suppression + '(defun zot (x) + (unwind-protect (print x))) + '((suspicious unwind-protect)) + "Warning: `unwind-protect' without unwind forms") + + (test-suppression + '(defun zot (x) + (cond + ((zerop x) 'zero) + (t 'nonzero) + (happy puppy))) + '((suspicious cond)) + "Warning: Useless clause following default `cond' clause") + + (test-suppression + '(defun zot () + (let ((_ 1)) + )) + '((empty-body let)) + "Warning: `let' with empty body") + + (test-suppression + '(defun zot () + (let* ((_ 1)) + )) + '((empty-body let*)) + "Warning: `let\\*' with empty body") + + (test-suppression + '(defun zot (x) + (when x + )) + '((empty-body when)) + "Warning: `when' with empty body") + + (test-suppression + '(defun zot (x) + (unless x + )) + '((empty-body unless)) + "Warning: `unless' with empty body") + + (test-suppression + '(defun zot (x) + (ignore-error arith-error + )) + '((empty-body ignore-error)) + "Warning: `ignore-error' with empty body") + + (test-suppression + '(defun zot (x) + (with-suppressed-warnings ((suspicious eq)) + )) + '((empty-body with-suppressed-warnings)) + "Warning: `with-suppressed-warnings' with empty body") + + (test-suppression + '(defun zot () + (setcar '(1 2) 3)) + '((mutate-constant setcar)) + "Warning: `setcar' on constant list (arg 1)") + + (test-suppression + '(defun zot () + (aset [1 2] 1 3)) + '((mutate-constant aset)) + "Warning: `aset' on constant vector (arg 1)") + + (test-suppression + '(defun zot () + (aset "abc" 1 ?d)) + '((mutate-constant aset)) + "Warning: `aset' on constant string (arg 1)") + + (test-suppression + '(defun zot (x y) + (nconc x y '(1 2) '(3 4))) + '((mutate-constant nconc)) + "Warning: `nconc' on constant list (arg 3)") + + (test-suppression + '(defun zot () + (put-text-property 0 2 'prop 'val "abc")) + '((mutate-constant put-text-property)) + "Warning: `put-text-property' on constant string (arg 5)") + ) (ert-deftest bytecomp-tests--not-writable-directory () "Test that byte compilation works if the output directory isn't @@ -1327,7 +1675,8 @@ writable (Bug#44631)." (byte-compile-error-on-warn t)) (unwind-protect (progn - (write-region "" nil input-file nil nil nil 'excl) + (write-region ";;; -*-lexical-binding:t-*-\n" + 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) @@ -1358,7 +1707,8 @@ mountpoint (Bug#44631)." (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 ";;; -*-lexical-binding:t-*-\n" + nil input-file nil nil nil 'excl) (write-region "" nil output-file nil nil nil 'excl) (unwind-protect (progn @@ -1391,7 +1741,8 @@ mountpoint (Bug#44631)." (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) + (write-region ";;; -*-lexical-binding:t-*-\n" + 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 @@ -1565,12 +1916,53 @@ 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-test-defcustom-type () + (cl-flet ((dc (type) `(defcustom mytest nil "doc" :type ',type :group 'test))) + (bytecomp--with-warning-test + (rx "type should not be quoted") (dc ''integer)) + (bytecomp--with-warning-test + (rx "type should not be quoted") (dc '(choice '(repeat boolean)))) + (bytecomp--with-warning-test + (rx "misplaced :tag keyword") (dc '(choice (const b :tag "a")))) + (bytecomp--with-warning-test + (rx "`choice' without any types inside") (dc '(choice :tag "a"))) + (bytecomp--with-warning-test + (rx "`other' not last in `choice'") + (dc '(choice (const a) (other b) (const c)))) + (bytecomp--with-warning-test + (rx "duplicated value in `choice': `a'") + (dc '(choice (const a) (const b) (const a)))) + (bytecomp--with-warning-test + (rx "duplicated :tag string in `choice': \"X\"") + (dc '(choice (const :tag "X" a) (const :tag "Y" b) (other :tag "X" c)))) + (bytecomp--with-warning-test + (rx "`cons' requires 2 type specs, found 1") + (dc '(cons :tag "a" integer))) + (bytecomp--with-warning-test + (rx "`repeat' without type specs") + (dc '(repeat :tag "a"))) + (bytecomp--with-warning-test + (rx "`const' with too many values") + (dc '(const :tag "a" x y))) + (bytecomp--with-warning-test + (rx "`const' with quoted value") + (dc '(const :tag "a" 'x))) + (bytecomp--with-warning-test + (rx "`bool' is not a valid type") + (dc '(bool :tag "a"))) + (bytecomp--with-warning-test + (rx "irregular type `:tag'") + (dc '(:tag "a"))) + (bytecomp--with-warning-test + (rx "irregular type `\"string\"'") + (dc '(list "string"))) + (bytecomp--with-warning-test + (rx "`list' without arguments") + (dc 'list)) + (bytecomp--with-warning-test + (rx "`integerp' is not a valid type") + (dc 'integerp)) + )) (ert-deftest bytecomp-function-attributes () ;; Check that `byte-compile' keeps the declarations, interactive spec and @@ -1662,6 +2054,135 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \ (should (eq (byte-compile-file src-file) 'no-byte-compile)) (should-not (file-exists-p dest-file)))) +(ert-deftest bytecomp--copy-tree () + (should (null (bytecomp--copy-tree nil))) + (let ((print-circle t)) + (let* ((x '(1 2 (3 4))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "((1 2 (3 4)) (1 2 (3 4)))"))) + (let* ((x '#1=(a #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(a #1#) #2=(a #2#))"))) + (let* ((x '#1=(#1# a)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(#1# a) #2=(#2# a))"))) + (let* ((x '((a . #1=(b)) #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(((a . #1=(b)) #1#) ((a . #2=(b)) #2#))"))) + (let* ((x '#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + (concat + "(" + "#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))" + " " + "#4=(a #5=(#4# b . #6=(#5# c . #4#)) (#6# d))" + ")")))))) + +(require 'backtrace) + +(defun bytecomp-tests--error-frame (fun args) + "Call FUN with ARGS. Return result or (ERROR . BACKTRACE-FRAME)." + (let* ((debugger + (lambda (&rest args) + ;; Make sure Emacs doesn't think our debugger is buggy. + (cl-incf num-nonmacro-input-events) + (throw 'bytecomp-tests--backtrace + (cons args (cadr (backtrace-get-frames debugger)))))) + (debug-on-error t) + (backtrace-on-error-noninteractive nil) + (debug-on-quit t) + (debug-ignored-errors nil)) + (catch 'bytecomp-tests--backtrace + (apply fun args)))) + +(defconst bytecomp-tests--byte-op-error-cases + '(((car a) (wrong-type-argument listp a)) + ((cdr 3) (wrong-type-argument listp 3)) + ((setcar 4 b) (wrong-type-argument consp 4)) + ((setcdr c 5) (wrong-type-argument consp c)) + ((nth 2 "abcd") (wrong-type-argument listp "abcd")) + ((elt (x y . z) 2) (wrong-type-argument listp z)) + ((aref [2 3 5] p) (wrong-type-argument fixnump p)) + ((aref #s(a b c) p) (wrong-type-argument fixnump p)) + ((aref "abc" p) (wrong-type-argument fixnump p)) + ((aref [2 3 5] 3) (args-out-of-range [2 3 5] 3)) + ((aref #s(a b c) 3) (args-out-of-range #s(a b c) 3)) + ((aset [2 3 5] q 1) (wrong-type-argument fixnump q)) + ((aset #s(a b c) q 1) (wrong-type-argument fixnump q)) + ((aset [2 3 5] -1 1) (args-out-of-range [2 3 5] -1)) + ((aset #s(a b c) -1 1) (args-out-of-range #s(a b c) -1)) + ;; Many more to add + )) + +(ert-deftest bytecomp--byte-op-error-backtrace () + "Check that signaling byte ops show up in the backtrace." + (dolist (case bytecomp-tests--byte-op-error-cases) + (ert-info ((prin1-to-string case) :prefix "case: ") + (let* ((call (nth 0 case)) + (expected-error (nth 1 case)) + (fun-sym (car call)) + (actuals (cdr call))) + ;; Test both calling the function directly, and calling + ;; a byte-compiled η-expansion (lambda (ARGS...) (FUN ARGS...)) + ;; which should turn the function call into a byte-op. + (dolist (mode '(funcall byte-op)) + (ert-info ((symbol-name mode) :prefix "mode: ") + (let* ((fun (pcase-exhaustive mode + ('funcall fun-sym) + ('byte-op + (let* ((nargs (length (cdr call))) + (formals (mapcar (lambda (i) + (intern (format "x%d" i))) + (number-sequence 1 nargs)))) + (byte-compile + `(lambda ,formals (,fun-sym ,@formals))))))) + (error-frame (bytecomp-tests--error-frame fun actuals))) + (should (consp error-frame)) + (should (equal (car error-frame) (list 'error expected-error))) + (let ((frame (cdr error-frame))) + (should (equal (type-of frame) 'backtrace-frame)) + (should (equal (cons (backtrace-frame-fun frame) + (backtrace-frame-args frame)) + call)))))))))) + +(ert-deftest bytecomp--eq-symbols-with-pos-enabled () + ;; Verify that we don't optimize away a binding of + ;; `symbols-with-pos-enabled' around an application of `eq' (bug#65017). + (let* ((sym-with-pos1 (read-positioning-symbols "sym")) + (sym-with-pos2 (read-positioning-symbols " sym")) ; <- space! + (without-pos-eq (lambda (a b) + (let ((symbols-with-pos-enabled nil)) + (eq a b)))) + (without-pos-eq-compiled (byte-compile without-pos-eq)) + (with-pos-eq (lambda (a b) + (let ((symbols-with-pos-enabled t)) + (eq a b)))) + (with-pos-eq-compiled (byte-compile with-pos-eq))) + (dolist (mode '(interpreted compiled)) + (ert-info ((symbol-name mode) :prefix "mode: ") + (ert-info ("disabled" :prefix "symbol-pos: ") + (let ((eq-fn (pcase-exhaustive mode + ('interpreted without-pos-eq) + ('compiled without-pos-eq-compiled)))) + (should (equal (funcall eq-fn 'sym 'sym) t)) + (should (equal (funcall eq-fn sym-with-pos1 'sym) nil)) + (should (equal (funcall eq-fn 'sym sym-with-pos1) nil)) + (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos1) t)) + (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos2) nil)))) + (ert-info ("enabled" :prefix "symbol-pos: ") + (let ((eq-fn (pcase-exhaustive mode + ('interpreted with-pos-eq) + ('compiled with-pos-eq-compiled)))) + (should (equal (funcall eq-fn 'sym 'sym) t)) + (should (equal (funcall eq-fn sym-with-pos1 'sym) t)) + (should (equal (funcall eq-fn 'sym sym-with-pos1) t)) + (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos1) t)) + (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos2) t)))))))) ;; 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 83013cf46a9..6facd3452ea 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -364,5 +364,30 @@ (call-interactively f)) '((t 51696) (nil 51695) (t 51697))))))) +(ert-deftest cconv-safe-for-space () + (let* ((magic-string "This-is-a-magic-string") + (safe-p (lambda (x) (not (string-match magic-string (format "%S" x)))))) + (should (funcall safe-p (lambda (x) (+ x 1)))) + (should (funcall safe-p (eval '(lambda (x) (+ x 1)) + `((y . ,magic-string))))) + (should (funcall safe-p (eval '(lambda (x) :closure-dont-trim-context) + `((y . ,magic-string))))) + (should-not (funcall safe-p + (eval '(lambda (x) :closure-dont-trim-context (+ x 1)) + `((y . ,magic-string))))))) + +(ert-deftest cconv-tests-interactive-form-modify-bug60974 () + (let* ((f '(function (lambda (&optional arg) + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle))) + (ignore arg)))) + (if (cadr (nth 2 (cadr f)))) + (if2)) + (cconv-closure-convert f) + (setq if2 (cadr (nth 2 (cadr f)))) + (should (eq if if2)))) + (provide 'cconv-tests) ;;; cconv-tests.el ends here diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el index 57694bd424b..242e41c7f08 100644 --- a/test/lisp/emacs-lisp/checkdoc-tests.el +++ b/test/lisp/emacs-lisp/checkdoc-tests.el @@ -37,6 +37,15 @@ (insert "(defun foo())") (should-error (checkdoc-defun) :type 'user-error))) +(ert-deftest checkdoc-docstring-avoid-false-positive-ok () + "Check that Bug#68002 is fixed." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(defvar org-element--cache-interrupt-C-g-count 0 + \"Current number of `org-element--cache-sync' calls. +See `org-element--cache-interrupt-C-g'.\")") + (checkdoc-defun))) + (ert-deftest checkdoc-cl-defmethod-ok () "Checkdoc should be happy with a simple correct cl-defmethod." (with-temp-buffer diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index d5886626bf1..0995e71db4e 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -404,7 +404,7 @@ (ert-deftest cl-lib-nth-value-test-multiple-values () "While CL multiple values are an alias to list, these won't work." :expected-result :failed - (should (eq (cl-nth-value 0 '(2 3)) '(2 3))) + (should (equal (cl-nth-value 0 '(2 3)) '(2 3))) (should (= (cl-nth-value 0 1) 1)) (should (null (cl-nth-value 1 1))) (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) @@ -431,7 +431,8 @@ (should (eq nums (cdr (cl-adjoin 3 nums)))) ;; add only when not already there (should (eq nums (cl-adjoin 2 nums))) - (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2))))) + (with-suppressed-warnings ((suspicious memql)) + (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2)))))) ;; default test function is eql (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums))) ;; own :test function - returns true if match @@ -529,27 +530,29 @@ (ert-deftest old-struct () (cl-defstruct foo x) - (let ((x [cl-struct-foo]) - (saved cl-old-struct-compat-mode)) - (cl-old-struct-compat-mode -1) - (should (eq (type-of x) 'vector)) + (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode)) + (let ((x (vector 'cl-struct-foo)) + (saved cl-old-struct-compat-mode)) + (cl-old-struct-compat-mode -1) + (should (eq (type-of x) 'vector)) - (cl-old-struct-compat-mode 1) - (defvar cl-struct-foo) - (let ((cl-struct-foo (cl--struct-get-class 'foo))) - (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) - (should (eq (type-of x) 'foo)) - (should (eq (type-of [foo]) 'vector))) + (cl-old-struct-compat-mode 1) + (defvar cl-struct-foo) + (let ((cl-struct-foo (cl--struct-get-class 'foo))) + (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) + (should (eq (type-of x) 'foo)) + (should (eq (type-of (vector 'foo)) 'vector))) - (cl-old-struct-compat-mode (if saved 1 -1)))) + (cl-old-struct-compat-mode (if saved 1 -1))))) (ert-deftest cl-lib-old-struct () - (let ((saved cl-old-struct-compat-mode)) - (cl-old-struct-compat-mode -1) - (cl-struct-define 'foo "" 'cl-structure-object nil nil nil - 'cl-struct-foo-tags 'cl-struct-foo t) - (should cl-old-struct-compat-mode) - (cl-old-struct-compat-mode (if saved 1 -1)))) + (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode)) + (let ((saved cl-old-struct-compat-mode)) + (cl-old-struct-compat-mode -1) + (cl-struct-define 'foo "" 'cl-structure-object nil nil nil + 'cl-struct-foo-tags 'cl-struct-foo t) + (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)) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index a9ec0b76ae8..56a49fd865a 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -535,7 +535,7 @@ collection clause." (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))) + (should (equal (let ((l (list 0))) (let ((cl (car l))) (cl-symbol-macrolet ((p (gv-synthetic-place cl (lambda (v) `(setcar l ,v))))) @@ -708,6 +708,23 @@ collection clause." (f lex-var))))) (should (equal (f nil) 'a))))) +(ert-deftest cl-flet/edebug () + "Check that we can instrument `cl-flet' forms (bug#65344)." + (with-temp-buffer + (print '(cl-flet (;; "Obscure" form of binding supported by cl-flet + (x (progn (list 1 2) (lambda ()))) + ;; Destructuring lambda-list + (y ((min max)) (list min max)) + ;; Regular binding plus shadowing. + (z (a) a) + (z (a) a)) + (y '(1 2))) + (current-buffer)) + (let ((edebug-all-forms t) + (edebug-initial-mode 'Go-nonstop)) + ;; Just make sure the forms can be instrumented. + (eval-buffer)))) + (ert-deftest cl-macs--progv () (defvar cl-macs--test) (defvar cl-macs--test1) @@ -803,10 +820,30 @@ See Bug#57915." (macroexpand form) (should (string-empty-p messages)))))))) +(defvar cl--test-a) + (ert-deftest cl-&key-arguments () (cl-flet ((fn (&key x) x)) (should-error (fn :x)) - (should (eq (fn :x :a) :a)))) - + (should (eq (fn :x :a) :a))) + ;; In ELisp function arguments are always statically scoped (bug#47552). + (let ((cl--test-a 'dyn) + ;; FIXME: How do we silence the "Lexical argument shadows" warning? + (f + (with-suppressed-warnings ((lexical cl--test-a)) + (cl-function (lambda (&key cl--test-a b) + (list cl--test-a (symbol-value 'cl--test-a) b)))))) + (should (equal (funcall f :cl--test-a 'lex :b 2) '(lex dyn 2))))) + +(cl-defstruct cl--test-s + cl--test-a b) + +(ert-deftest cl-defstruct-dynbound-label-47552 () + "Check that labels can have the same name as dynbound vars." + (let ((cl--test-a 'dyn)) + (let ((x (make-cl--test-s :cl--test-a 4 :b cl--test-a))) + (should (cl--test-s-p x)) + (should (equal (cl--test-s-cl--test-a x) 4)) + (should (equal (cl--test-s-b x) 'dyn))))) ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el index 7161035d75a..631dd834a68 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'cl-print) (cl-defstruct (cl-print-tests-struct (:constructor cl-print-tests-con)) @@ -59,18 +60,20 @@ (ert-deftest cl-print-tests-ellipsis-string () "Ellipsis expansion works in strings." - (let ((print-length 4) - (print-level 3)) + (let ((cl-print-string-length 4)) (cl-print-tests-check-ellipsis-expansion "abcdefg" "\"abcd...\"" "efg") (cl-print-tests-check-ellipsis-expansion "abcdefghijk" "\"abcd...\"" "efgh...") - (cl-print-tests-check-ellipsis-expansion - '(1 (2 (3 #("abcde" 0 5 (test t))))) - "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))") - (cl-print-tests-check-ellipsis-expansion - #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t)) - "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ..."))) + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + '(1 (2 (3 #("abcde" 0 5 (test t))))) + "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))")) + (let ((print-length 4)) + (cl-print-tests-check-ellipsis-expansion + #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t)) + "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ...")))) (ert-deftest cl-print-tests-ellipsis-struct () "Ellipsis expansion works in structures." @@ -90,7 +93,7 @@ (ert-deftest cl-print-tests-ellipsis-circular () "Ellipsis expansion works with circular objects." (let ((wide-obj (list 0 1 2 3 4)) - (deep-obj `(0 (1 (2 (3 (4)))))) + (deep-obj (list 0 (list 1 (list 2 (list 3 (list 4)))))) (print-length 4) (print-level 3)) (setf (nth 4 wide-obj) wide-obj) @@ -113,7 +116,7 @@ (should pos) (setq value (get-text-property pos 'cl-print-ellipsis result)) (should (equal expected result)) - (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis + (should (equal expanded (with-output-to-string (cl-print--expand-ellipsis value nil)))))) (defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded) @@ -122,7 +125,7 @@ (value (get-text-property pos 'cl-print-ellipsis result))) (should (string-match expected result)) (should (string-match expanded (with-output-to-string - (cl-print-expand-ellipsis value nil)))))) + (cl-print--expand-ellipsis value nil)))))) (ert-deftest cl-print-tests-print-to-string-with-limit () (let* ((thing10 (make-list 10 'a)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 78d9bb49b98..cbedce0c47d 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -42,14 +42,14 @@ ',expected-type-spec)))) (defconst comp-cstr-typespec-tests-alist - `(;; 1 + '(;; 1 (symbol . symbol) ;; 2 ((or string array) . array) ;; 3 ((or symbol number) . (or number symbol)) ;; 4 - ((or cons atom) . (or atom cons)) ;; SBCL return T + ((or cons atom) . t) ;; SBCL return T ;; 5 ((or integer number) . number) ;; 6 @@ -191,7 +191,7 @@ ;; 74 ((and boolean (or number marker)) . nil) ;; 75 - ((and atom (or number marker)) . (or marker number)) + ((and atom (or number marker)) . number-or-marker) ;; 76 ((and symbol (or number marker)) . nil) ;; 77 @@ -217,7 +217,20 @@ ;; 87 ((and (or null integer) (not (or null integer))) . nil) ;; 88 - ((and (or (member a b c)) (not (or (member a b)))) . (member c))) + ((and (or (member a b c)) (not (or (member a b)))) . (member c)) + ;; 89 + ((or cons symbol) . (or list symbol)) ;; FIXME: Why `list'? + ;; 90 + ((or string char-table bool-vector vector) . array) + ;; 91 + ((or string char-table bool-vector vector number) . (or array number)) + ;; 92 + ((or string char-table bool-vector vector cons symbol number) . + (or number sequence symbol)) + ;; 93? + ;; FIXME: I get `cons' rather than `list'? + ;;((or null cons) . list) + ) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index de2fff5ef19..28a7f38c576 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -116,6 +116,7 @@ back to the top level.") (with-current-buffer (find-file edebug-tests-temp-file) (read-only-mode) (setq lexical-binding t) + (syntax-ppss) (eval-buffer) ,@body (when edebug-tests-failure-in-post-command 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 4feaebed452..4f13881dbd4 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -40,7 +40,7 @@ This is usually a symbol that starts with `:'." (car tuple) nil))) -(defun hash-equal (hash1 hash2) +(defun eieio-test--hash-equal (hash1 hash2) "Compare two hash tables to see whether they are equal." (and (= (hash-table-count hash1) (hash-table-count hash2)) @@ -78,7 +78,7 @@ This is usually a symbol that starts with `:'." (if initarg-p (unless (cond ((and (hash-table-p origvalue) (hash-table-p fromdiskvalue)) - (hash-equal origvalue fromdiskvalue)) + (eieio-test--hash-equal origvalue fromdiskvalue)) (t (equal origvalue fromdiskvalue))) (error "Slot %S Original Val %S != Persistent Val %S" oneslot origvalue fromdiskvalue)) @@ -87,7 +87,7 @@ This is usually a symbol that starts with `:'." (diskval fromdiskvalue)) (unless (cond ((and (hash-table-p origval) (hash-table-p diskval)) - (hash-equal origval diskval)) + (eieio-test--hash-equal origval diskval)) (t (equal origval diskval))) (error "Slot %S Persistent Val %S != Default Value %S" oneslot diskval origvalue)))))))) @@ -329,8 +329,8 @@ persistent class.") "container-" emacs-version ".eieio"))) (john (make-instance 'person :name "John")) (alexie (make-instance 'person :name "Alexie")) - (alst '(("first" (one two three)) - ("second" (four five six))))) + (alst (list (list "first" (list 'one 'two 'three)) + (list "second" (list 'four 'five 'six))))) (setf (slot-value thing 'alist) alst) (puthash "alst" alst (slot-value thing 'htab)) (aset (slot-value thing 'vec) 0 alst) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index c9993341f98..a0507afe833 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -1046,6 +1046,27 @@ Subclasses to override slot attributes.")) (should (eq (eieio-test--struct-a x) 1)) (should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only))) +(defclass foo-bug-66938 (eieio-instance-inheritor) + ((x :initarg :x + :accessor ref-x + :reader get-x)) + "A class to test that delegation occurs under certain +circumstances when using an accessor function, as it would when +using the reader function.") + +(ert-deftest eieio-test-use-accessor-function-with-cloned-object () + "The class FOO-BUG-66938 is a subclass of +`eieio-instance-inheritor'. Therefore, given an instance OBJ1 of +FOO-BUG-66938, and a clone (OBJ2), OBJ2 should delegate to OBJ1 +when accessing an unbound slot. + +In particular, its behavior should be identical to that of the +reader function, when reading a slot." + (let* ((obj1 (foo-bug-66938 :x 4)) + (obj2 (clone obj1))) + (should (eql (ref-x obj2) 4)) + (should (eql (get-x obj2) (ref-x obj2))))) + (provide 'eieio-tests) ;;; eieio-tests.el ends here diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js b/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js new file mode 100644 index 00000000000..69c1c5cca88 --- /dev/null +++ b/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js @@ -0,0 +1,3 @@ +var abc = function(d) { +// ^ wrong-face +}; diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js b/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js new file mode 100644 index 00000000000..5e614c64755 --- /dev/null +++ b/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js @@ -0,0 +1,3 @@ +var abc = function(d) { +// ^ font-lock-variable-name-face +}; diff --git a/test/lisp/emacs-lisp/ert-font-lock-tests.el b/test/lisp/emacs-lisp/ert-font-lock-tests.el new file mode 100644 index 00000000000..33ef0c6eede --- /dev/null +++ b/test/lisp/emacs-lisp/ert-font-lock-tests.el @@ -0,0 +1,464 @@ +;;; ert-font-lock-tests.el --- ERT Font Lock tests -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Vladimir Kazanov + +;; 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: + +;; This file is part of ERT Font Lock, an extension to the Emacs Lisp +;; Regression Test library (ERT) providing a convenient way to check +;; syntax highlighting provided by font-lock. +;; +;; See ert-font-lock.el for details, and below for example usage of +;; ert-font-lock facilities. + +(require 'ert) +(require 'ert-x) +(require 'ert-font-lock) + +;;; Helpers +;; + +(defmacro with-temp-buffer-str-mode (mode str &rest body) + "Create a buffer with STR contents and MODE. " + (declare (indent 1) (debug t)) + `(with-temp-buffer + (insert ,str) + (,mode) + (goto-char (point-min)) + ,@body)) + +;;; Comment parsing tests +;; + +(ert-deftest test-line-comment-p--fundamental () + (with-temp-buffer-str-mode fundamental-mode + "// comment\n" + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--emacs-lisp () + (with-temp-buffer-str-mode emacs-lisp-mode + "not comment +;; comment +" + (should-not (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)) + (forward-line) + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--shell-script () + (with-temp-buffer-str-mode shell-script-mode + "echo Not a comment +# comment +" + (should-not (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)))) + +(declare-function php-mode "php-mode") +(ert-deftest test-line-comment-p--php () + (skip-unless (featurep 'php-mode)) + + (with-temp-buffer-str-mode php-mode + "echo 'Not a comment' +// comment +/* comment */ +" + (should-not (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)))) + + +(ert-deftest test-line-comment-p--javascript () + (with-temp-buffer-str-mode javascript-mode + "// comment + + // comment, after a blank line + +var abc = function(d) {}; +" + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)) + + (forward-line) + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--python () + + (with-temp-buffer-str-mode python-mode + "# comment + + # comment +print(\"Hello, world!\")" + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)) + + (forward-line) + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--c () + + (with-temp-buffer-str-mode c-mode + "// comment +/* also comment */" + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should (ert-font-lock--line-comment-p)))) + +(ert-deftest test-parse-comments--single-line-error () + (let* ((str "// ^ face.face1")) + (with-temp-buffer + (insert str) + (javascript-mode) + + (should-error (ert-font-lock--parse-comments))))) + +(ert-deftest test-parse-comments--single-line-single-caret () + (let* ((str " +first +// ^ face.face1 +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 2 :line-assert 3 :column-checked 3 :face "face.face1" :negation nil)))))) + +(ert-deftest test-parse-comments--caret-negation () + (let* ((str " +first +// ^ !face +// ^ face +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 2)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face" :negation t) + (:line-checked 2 :line-assert 4 :column-checked 3 :face "face" :negation nil))))))) + + +(ert-deftest test-parse-comments--single-line-multiple-carets () + (let* ((str " +first +// ^ face1 +// ^ face.face2 +// ^ face-face.face3 + // ^ face_face.face4 +") + asserts) + + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 4)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face1" :negation nil) + (:line-checked 2 :line-assert 4 :column-checked 7 :face "face.face2" :negation nil) + (:line-checked 2 :line-assert 5 :column-checked 7 :face "face-face.face3" :negation nil) + (:line-checked 2 :line-assert 6 :column-checked 7 :face "face_face.face4" :negation nil))))))) + +(ert-deftest test-parse-comments--multiple-line-multiple-carets () + (let* ((str " +first +// ^ face1 +second +// ^ face2 +// ^ face3 +third +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 3)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face1" :negation nil) + (:line-checked 4 :line-assert 5 :column-checked 3 :face "face2" :negation nil) + (:line-checked 4 :line-assert 6 :column-checked 5 :face "face3" :negation nil))))))) + + +(ert-deftest test-parse-comments--arrow-single-line-single () + (let* ((str " +first +// <- face1 +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 2 :line-assert 3 :column-checked 0 :face "face1" :negation nil)))))) + + +(ert-deftest test-parse-comments-arrow-multiple-line-single () + (let* ((str " +first +// <- face1 + // <- face2 + // <- face3 +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 3)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 0 :face "face1" :negation nil) + (:line-checked 2 :line-assert 4 :column-checked 2 :face "face2" :negation nil) + (:line-checked 2 :line-assert 5 :column-checked 4 :face "face3" :negation nil))))))) + +(ert-deftest test-parse-comments--non-assert-comment-single () + (let* ((str " +// first +// ^ comment-face +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 2 :line-assert 3 :column-checked 4 :face "comment-face" :negation nil)))))) + +(ert-deftest test-parse-comments--non-assert-comment-multiple () + (let* ((str " +// first second third +// ^ comment-face +// ^ comment-face +// ^ comment-face +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 3)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 4 :face "comment-face" :negation nil) + (:line-checked 2 :line-assert 4 :column-checked 10 :face "comment-face" :negation nil) + (:line-checked 2 :line-assert 5 :column-checked 18 :face "comment-face" :negation nil))))))) + + +(ert-deftest test-parse-comments--multiline-comment-single () + (let* ((str " +/* + this is a comment + ^ comment-face + */ +") + asserts) + (with-temp-buffer + (insert str) + (c-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 3 :line-assert 4 :column-checked 3 :face "comment-face" :negation nil)))))) + +(ert-deftest test-parse-comments--multiline-comment-multiple () + (let* ((str " +/* + this is a comment + ^ comment-face + another comment + ^ comment-face + */ +") + asserts) + (with-temp-buffer + (insert str) + (c-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 2)) + (should (equal asserts + '((:line-checked 3 :line-assert 4 :column-checked 3 :face "comment-face" :negation nil) + (:line-checked 5 :line-assert 6 :column-checked 4 :face "comment-face" :negation nil))))))) + +;;; Syntax highlighting assertion tests +;; + +(ert-deftest test-syntax-highlight-inline--caret-multiple-faces () + (let ((str " +var abc = function(d) { +// ^ font-lock-variable-name-face + // ^ font-lock-keyword-face + // ^ font-lock-variable-name-face +}; + +")) + (with-temp-buffer + (insert str) + (javascript-mode) + (font-lock-ensure) + + (ert-font-lock--check-faces + (ert-font-lock--parse-comments))))) + +(ert-deftest test-syntax-highlight-inline--caret-wrong-face () + (let* ((str " +var abc = function(d) { +// ^ not-a-face +}; +")) + (with-temp-buffer + (insert str) + (javascript-mode) + (font-lock-ensure) + + (should-error (ert-font-lock--check-faces + (ert-font-lock--parse-comments)))))) + + +(ert-deftest test-syntax-highlight-inline--comment-face () + (let* ((str " +// this is a comment +// ^ font-lock-comment-face +// ^ font-lock-comment-face +// ^ font-lock-comment-face +")) + (with-temp-buffer + (insert str) + (javascript-mode) + (font-lock-ensure) + + (ert-font-lock--check-faces + (ert-font-lock--parse-comments))))) + + +(ert-deftest test-syntax-highlight-inline--multiline-comment-face () + (let* ((str " +/* + this is a comment + ^ font-lock-comment-face + another comment + more comments + ^ font-lock-comment-face + */ +")) + (with-temp-buffer + (insert str) + (c-mode) + (font-lock-ensure) + + (ert-font-lock--check-faces + (ert-font-lock--parse-comments))))) + + +(ert-deftest test-font-lock-test-string--correct () + (ert-font-lock-test-string + " +var abc = function(d) { +// <- font-lock-keyword-face +// ^ font-lock-variable-name-face + // ^ font-lock-keyword-face + // ^ font-lock-variable-name-face +}; + +" + 'javascript-mode)) + +(ert-deftest test-font-lock-test-file--correct () + (ert-font-lock-test-file + (ert-resource-file "correct.js") + 'javascript-mode)) + +(ert-deftest test-font-lock-test-file--wrong () + :expected-result :failed + (ert-font-lock-test-file + (ert-resource-file "broken.js") + 'javascript-mode)) + +;;; Macro tests +;; + +(ert-font-lock-deftest test-macro-test--correct-highlighting + emacs-lisp-mode + " +(defun fun ()) +;; ^ font-lock-keyword-face +;; ^ font-lock-function-name-face") + +(ert-font-lock-deftest test-macro-test--docstring + "A test with a docstring." + emacs-lisp-mode + " +(defun fun ()) +;; ^ font-lock-keyword-face" + ) + +(ert-font-lock-deftest test-macro-test--failing + "A failing test." + :expected-result :failed + emacs-lisp-mode + " +(defun fun ()) +;; ^ wrong-face") + +(ert-font-lock-deftest-file test-macro-test--file + "Test reading correct assertions from a file" + javascript-mode + "correct.js") + +(ert-font-lock-deftest-file test-macro-test--file-failing + "Test reading wrong assertions from a file" + :expected-result :failed + javascript-mode + "broken.js") + +;;; ert-font-lock-tests.el ends here diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 3e499fc6f59..bb3de111e3e 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -304,6 +304,20 @@ failed or if there was a problem." (cl-macrolet ((test () (error "Foo"))) (should-error (test)))) +(ert-deftest ert-test-skip-when () + ;; Don't skip. + (let ((test (make-ert-test :body (lambda () (skip-when nil))))) + (let ((result (ert-run-test test))) + (should (ert-test-passed-p result)))) + ;; Skip. + (let ((test (make-ert-test :body (lambda () (skip-when t))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result)))) + ;; Skip in case of error. + (let ((test (make-ert-test :body (lambda () (skip-when (error "Foo")))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result))))) + (ert-deftest ert-test-skip-unless () ;; Don't skip. (let ((test (make-ert-test :body (lambda () (skip-unless t))))) @@ -577,13 +591,12 @@ This macro is used to test if macroexpansion in `should' works." (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 ((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 @@ -609,14 +622,13 @@ This macro is used to test if macroexpansion in `should' works." (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 ((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) diff --git a/test/lisp/emacs-lisp/find-func-tests.el b/test/lisp/emacs-lisp/find-func-tests.el index 7251b76157b..59ecb5ab187 100644 --- a/test/lisp/emacs-lisp/find-func-tests.el +++ b/test/lisp/emacs-lisp/find-func-tests.el @@ -32,7 +32,7 @@ (ert-deftest find-func-tests--library-completion () ;bug#43393 ;; FIXME: How can we make this work in batch (see also ;; `mule-cmds--test-universal-coding-system-argument')? - ;; (skip-unless (not noninteractive)) + ;; (skip-when noninteractive) ;; Check that `partial-completion' works when completing library names. (should (equal "org/org" (ert-simulate-keys diff --git a/test/lisp/emacs-lisp/lisp-mnt-tests.el b/test/lisp/emacs-lisp/lisp-mnt-tests.el index c056761f0f9..1418abf221f 100644 --- a/test/lisp/emacs-lisp/lisp-mnt-tests.el +++ b/test/lisp/emacs-lisp/lisp-mnt-tests.el @@ -30,6 +30,26 @@ '(("Bob Weiner" . "rsw@gnu.org") ("Mats Lidell" . "matsl@gnu.org"))))) +(ert-deftest lm--tests-lm-package-requires () + (with-temp-buffer + (insert ";; Package-Requires: ((emacs 29.1))") + (should (equal (lm-package-requires) '((emacs 29.1))))) + (with-temp-buffer + (insert ";; Package-Requires: ((emacs \"26.3\") (jsonrpc \"1.0.16\") (flymake \"1.2.1\") (project \"0.9.8\") (xref \"1.6.2\") (eldoc \"1.14.0\") (seq \"2.23\") (external-completion \"0.1\"))") + (should (equal (lm-package-requires) + '((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1") + (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") + (seq "2.23") (external-completion "0.1"))))) + (with-temp-buffer + (insert ";; Package-Requires: ((emacs \"26.3\") (jsonrpc \"1.0.16\") (flymake \"1.2.1\")\n" + ";; (project \"0.9.8\") (xref \"1.6.2\") (eldoc \"1.14.0\")\n" + ";; (seq \"2.23\") (external-completion \"0.1\"))") + (should (equal (lm-package-requires) + '((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1") + (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") + (seq "2.23") (external-completion "0.1")))))) + + (ert-deftest lm--tests-lm-website () (with-temp-buffer (insert ";; URL: https://example.org/foo") diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el index 3e906497020..825e6b6ab80 100644 --- a/test/lisp/emacs-lisp/lisp-mode-tests.el +++ b/test/lisp/emacs-lisp/lisp-mode-tests.el @@ -355,5 +355,28 @@ Expected initialization file: `%s'\" ;; (should (equal (lisp-current-defun-name) "defblarg"))) ) +(ert-deftest test-font-lock-keywords () + "Keywords should be fontified in `font-lock-keyword-face`." + (with-temp-buffer + (emacs-lisp-mode) + (mapc (lambda (el-keyword) + (erase-buffer) + (insert (format "(%s some-symbol () \"hello\"" el-keyword)) + (font-lock-ensure) + ;; Verify face property throughout the keyword + (let* ((begin (1+ (point-min))) + (end (1- (+ begin (length el-keyword))))) + (mapc (lambda (pos) + (should (equal (get-text-property pos 'face) + 'font-lock-keyword-face))) + (number-sequence begin end)))) + '("defsubst" "cl-defsubst" "define-inline" + "define-advice" "defadvice" "defalias" + "define-derived-mode" "define-minor-mode" + "define-generic-mode" "define-global-minor-mode" + "define-globalized-minor-mode" "define-skeleton" + "define-widget" "ert-deftest" "defconst" "defcustom" + "defvaralias" "defvar-local" "defface" "define-error")))) + (provide 'lisp-mode-tests) ;;; lisp-mode-tests.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el index 7bb38fe58f7..d0efbfd28c1 100644 --- a/test/lisp/emacs-lisp/macroexp-tests.el +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -124,4 +124,20 @@ (dyn dyn dyn dyn) (dyn dyn dyn lex)))))) +(defmacro macroexp--test-macro1 () + (declare (obsolete "new-replacement" nil)) + 1) + +(defmacro macroexp--test-macro2 () + '(macroexp--test-macro1)) + +(ert-deftest macroexp--test-obsolete-macro () + (should + (let ((res + (cl-letf (((symbol-function 'message) #'user-error)) + (condition-case err + (macroexpand-all '(macroexp--test-macro2)) + (user-error (error-message-string err)))))) + (should (and (stringp res) (string-match "new-replacement" res)))))) + ;;; macroexp-tests.el ends here diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 86c0e9e0503..2204743f794 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -577,6 +577,13 @@ See bug#58531#25 and bug#58563." (should (= b 2)) (should-not c))) +(ert-deftest test-map-let-default () + (map-let (('foo a 3) + ('baz b 4)) + '((foo . 1)) + (should (equal a 1)) + (should (equal b 4)))) + (ert-deftest test-map-merge () "Test `map-merge'." (should (equal (sort (map-merge 'list '(a 1) '((b . 2) (c . 3)) @@ -617,6 +624,58 @@ See bug#58531#25 and bug#58563." (list one two)) '(1 2))))) +(ert-deftest test-map-plist-pcase-default () + (let ((plist '(:two 2))) + (should (equal (pcase-let (((map (:two two 33) + (:three three 44)) + plist)) + (list two three)) + '(2 44))))) + +(ert-deftest test-map-pcase-matches () + (let ((plist '(:two 2))) + (should (equal (pcase plist + ((map (:two two 33) + (:three three)) + (list two three)) + (_ 'fail)) + '(2 nil))) + + (should (equal (pcase plist + ((map (:two two 33) + (:three three 44)) + (list two three)) + (_ 'fail)) + '(2 44))) + + (should (equal (pcase plist + ((map (:two two 33) + (:three `(,a . ,b) '(11 . 22))) + (list two a b)) + (_ 'fail)) + '(2 11 22))) + + (should (equal 'fail + (pcase plist + ((map (:two two 33) + (:three `(,a . ,b) 44)) + (list two a b)) + (_ 'fail)))) + + (should (equal 'fail + (pcase plist + ((map (:two two 33) + (:three `(,a . ,b) nil)) + (list two a b)) + (_ 'fail)))) + + (should (equal 'fail + (pcase plist + ((map (:two two 33) + (:three `(,a . ,b))) + (list two a b)) + (_ 'fail)))))) + (ert-deftest test-map-setf-alist-insert-key () (let ((alist)) (should (equal (setf (map-elt alist 'key) 'value) diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el index c55db6491cd..639a8ab5219 100644 --- a/test/lisp/emacs-lisp/multisession-tests.el +++ b/test/lisp/emacs-lisp/multisession-tests.el @@ -94,7 +94,7 @@ (dotimes (i 100) (cl-incf (multisession-value multisession--bar)))))))) (while (process-live-p proc) - (ignore-error 'sqlite-locked-error + (ignore-error sqlite-locked-error (message "multisession--bar %s" (multisession-value multisession--bar)) ;;(cl-incf (multisession-value multisession--bar)) ) diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index 748d42f2120..7dfa936214a 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -29,6 +29,7 @@ (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2))) (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) (defun sm-test1 (x) (+ x 4)) + (declare-function sm-test1 nil) (should (equal (sm-test1 6) 20)) (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2))) (should (equal (sm-test1 6) 10)) @@ -62,9 +63,11 @@ (ert-deftest advice-tests-advice () "Test advice code." (defun sm-test2 (x) (+ x 4)) + (declare-function sm-test2 nil) (should (equal (sm-test2 6) 10)) - (defadvice sm-test2 (around sm-test activate) - ad-do-it (setq ad-return-value (* ad-return-value 5))) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test2 (around sm-test activate) + ad-do-it (setq ad-return-value (* ad-return-value 5)))) (should (equal (sm-test2 6) 50)) (ad-deactivate 'sm-test2) (should (equal (sm-test2 6) 10)) @@ -79,8 +82,9 @@ (should (equal (sm-test2 6) 20)) (should (equal (null (get 'sm-test2 'defalias-fset-function)) t)) - (defadvice sm-test4 (around wrap-with-toto activate) - ad-do-it (setq ad-return-value `(toto ,ad-return-value))) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test4 (around wrap-with-toto activate) + ad-do-it (setq ad-return-value `(toto ,ad-return-value)))) (defmacro sm-test4 (x) `(call-test4 ,x)) (should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56)))) (defmacro sm-test4 (x) `(call-testq ,x)) @@ -88,17 +92,20 @@ ;; This used to signal an error (bug#12858). (autoload 'sm-test6 "foo") - (defadvice sm-test6 (around test activate) - ad-do-it)) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test6 (around test activate) + ad-do-it))) (ert-deftest advice-tests-combination () "Combining old style and new style advices." (defun sm-test5 (x) (+ x 4)) + (declare-function sm-test5 nil) (should (equal (sm-test5 6) 10)) (advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) (should (equal (sm-test5 6) 50)) - (defadvice sm-test5 (around test activate) - ad-do-it (setq ad-return-value (+ ad-return-value 0.1))) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test5 (around test activate) + ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))) (should (equal (sm-test5 5) 45.1)) (ad-deactivate 'sm-test5) (should (equal (sm-test5 6) 50)) @@ -112,22 +119,23 @@ (ert-deftest advice-test-called-interactively-p () "Check interaction between advice and called-interactively-p." (defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4)) + (declare-function sm-test7 nil) (advice-add 'sm-test7 :around (lambda (f &rest args) - (list (cons 1 (called-interactively-p)) (apply f args)))) + (list (cons 1 (called-interactively-p 'any)) (apply f args)))) (should (equal (sm-test7) '((1 . nil) 11))) (should (equal (call-interactively 'sm-test7) '((1 . t) 11))) (let ((smi 7)) (advice-add 'sm-test7 :before - (lambda (&rest args) - (setq smi (called-interactively-p)))) + (lambda (&rest _args) + (setq smi (called-interactively-p 'any)))) (should (equal (list (sm-test7) smi) '(((1 . nil) 11) nil))) (should (equal (list (call-interactively 'sm-test7) smi) '(((1 . t) 11) t)))) (advice-add 'sm-test7 :around (lambda (f &rest args) - (cons (cons 2 (called-interactively-p)) (apply f args)))) + (cons (cons 2 (called-interactively-p 'any)) (apply f args)))) (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))) (ert-deftest advice-test-called-interactively-p-around () @@ -136,24 +144,28 @@ This tests the currently broken case of the innermost advice to a function being an around advice." :expected-result :failed - (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p))) + (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p 'any))) + (declare-function sm-test7.2 nil) (advice-add 'sm-test7.2 :around (lambda (f &rest args) - (list (cons 1 (called-interactively-p)) (apply f args)))) + (list (cons 1 (called-interactively-p 'any)) (apply f args)))) (should (equal (sm-test7.2) '((1 . nil) (1 . nil)))) (should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t))))) (ert-deftest advice-test-called-interactively-p-filter-args () "Check interaction between filter-args advice and called-interactively-p." :expected-result :failed - (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p))) + (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p 'any))) + (declare-function sm-test7.3 nil) (advice-add 'sm-test7.3 :filter-args #'list) (should (equal (sm-test7.3) '(1 . nil))) (should (equal (call-interactively 'sm-test7.3) '(1 . t)))) (ert-deftest advice-test-call-interactively () "Check interaction between advice on call-interactively and called-interactively-p." - (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p)))) + (let ((sm-test7.4 (lambda () + (interactive) + (cons 1 (called-interactively-p 'any)))) (old (symbol-function 'call-interactively))) (unwind-protect (progn @@ -166,18 +178,20 @@ function being an around advice." (ert-deftest advice-test-interactive () "Check handling of interactive spec." (defun sm-test8 (a) (interactive "p") a) - (defadvice sm-test8 (before adv1 activate) nil) - (defadvice sm-test8 (before adv2 activate) (interactive "P") nil) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test8 (before adv1 activate) nil) + (defadvice sm-test8 (before adv2 activate) (interactive "P") nil)) (should (equal (interactive-form 'sm-test8) '(interactive "P")))) (ert-deftest advice-test-preactivate () (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) (defun sm-test9 (a) (interactive "p") a) (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) - (defadvice sm-test9 (before adv1 pre act protect compile) nil) - (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil)) - (defadvice sm-test9 (before adv2 pre act protect compile) - (interactive "P") nil) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test9 (before adv1 pre act protect compile) nil) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil)) + (defadvice sm-test9 (before adv2 pre act protect compile) + (interactive "P") nil)) (should (equal (interactive-form 'sm-test9) '(interactive "P")))) (ert-deftest advice-test-multiples () @@ -213,8 +227,16 @@ function being an around advice." (should (equal (cl-prin1-to-string (car x)) "#f(advice first :before #f(advice car :after cdr))")))) -;; Local Variables: -;; no-byte-compile: t -;; End: +(ert-deftest advice-test-bug61179 () + (let* ((magic 42) + (ad (lambda (&rest _) + (interactive (lambda (is) + (cons magic (advice-eval-interactive-spec is)))) + nil)) + (sym (make-symbol "adtest"))) + (defalias sym (lambda (&rest args) (interactive (list 'main)) args)) + (should (equal (call-interactively sym) '(main))) + (advice-add sym :before ad) + (should (equal (call-interactively sym) '(42 main))))) ;;; nadvice-tests.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 0016fb586b7..e44ad3677d1 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -125,6 +125,7 @@ abbreviated-home-dir package--initialized package-alist + package-selected-packages ,@(if update-news '(package-update-news-on-upload t) (list (cl-gensym))) @@ -219,9 +220,14 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-desc-from-buffer () "Parse an elisp buffer to get a `package-desc' object." - (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el") - (should (package-test--compatible-p - (package-buffer-info) simple-single-desc 'kind))) + (with-package-test (:basedir (ert-resource-directory) + :file "simple-single-1.3.el") + (let ((pi (package-buffer-info))) + (should (package-test--compatible-p pi simple-single-desc 'kind)) + ;; The terminating line is not mandatory any more. + (re-search-forward "^;;; .* ends here") + (delete-region (match-beginning 0) (point-max)) + (should (equal (package-buffer-info) pi)))) (with-package-test (:basedir (ert-resource-directory) :file "simple-depend-1.0.el") (should (package-test--compatible-p (package-buffer-info) simple-depend-desc 'kind))) @@ -302,6 +308,21 @@ Must called from within a `tar-mode' buffer." (package-delete (cadr (assq 'v7-withsub package-alist)))) )) +(ert-deftest package-test-bug65475 () + "Deleting the last package clears `package-selected-packages'." + (with-package-test (:basedir (ert-resource-directory)) + (package-initialize) + (let* ((pkg-el "simple-single-1.3.el") + (source-file (expand-file-name pkg-el (ert-resource-directory)))) + (package-install-file source-file) + (should package-alist) + (should package-selected-packages) + (let ((desc (cadr (assq 'simple-single package-alist)))) + (should desc) + (package-delete desc)) + (should-not package-alist) + (should-not package-selected-packages)))) + (ert-deftest package-test-install-file-EOLs () "Install same file multiple time with `package-install-file' but with a different end of line convention (bug#48137)." diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el index 72c7cb880d2..1b248e19a31 100644 --- a/test/lisp/emacs-lisp/pp-tests.el +++ b/test/lisp/emacs-lisp/pp-tests.el @@ -23,8 +23,8 @@ (require 'ert-x) (ert-deftest pp-print-quote () - (should (string= (pp-to-string 'quote) "quote")) - (should (string= (pp-to-string ''quote) "'quote")) + (should (string= (pp-to-string 'quote) "quote\n")) + (should (string= (pp-to-string ''quote) "'quote\n")) (should (string= (pp-to-string '('a 'b)) "('a 'b)\n")) (should (string= (pp-to-string '(''quote 'quote)) "(''quote 'quote)\n")) (should (string= (pp-to-string '(quote)) "(quote)\n")) diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 9c8628a8f26..e773ddf158e 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -41,19 +41,31 @@ (should (equal (rx "" (or "ab" nonl) "") "ab\\|."))) +;; FIXME: Extend tests for `or', `not' etc to cover char pattern combination, +;; including (syntax whitespace) and (syntax word). + (ert-deftest rx-or () - (should (equal (rx (or "ab" (| "c" nonl) "de")) - "ab\\|c\\|.\\|de")) + (should (equal (rx (or "ab" (| "cd" nonl) "de")) + "ab\\|cd\\|.\\|de")) (should (equal (rx (or "ab" "abc" ?a)) "\\(?:a\\(?:bc?\\)?\\)")) (should (equal (rx (or "ab" (| (or "abcd" "abcde")) (or "a" "abc"))) "\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)")) (should (equal (rx (or "a" (eval (string ?a ?b)))) "\\(?:ab?\\)")) + (should (equal (rx (| nonl "ac") (| "bd" blank)) + "\\(?:.\\|ac\\)\\(?:bd\\|[[:blank:]]\\)")) (should (equal (rx (| nonl "a") (| "b" blank)) - "\\(?:.\\|a\\)\\(?:b\\|[[:blank:]]\\)")) + ".[b[:blank:]]")) (should (equal (rx (|)) - "\\`a\\`"))) + "\\`a\\`")) + (should (equal (rx (or "a" (not anychar) punct ?c "b" (not (not ?d)))) + "[a-d[:punct:]]")) + (should (equal (rx (or nonl ?\n)) + "[^z-a]")) + (should (equal (rx (or "ab" "a" "b" blank (syntax whitespace) word "z")) + "ab\\|[ab[:blank:]]\\|\\s-\\|[z[:word:]]")) + ) (ert-deftest rx-def-in-or () (rx-let ((a b) @@ -98,7 +110,21 @@ "[\177Å\211\326-\377]")) ;; Split range; \177-\377ÿ should not be optimized to \177-\377. (should (equal (rx (any "\177-\377" ?ÿ)) - "[\177ÿ\200-\377]"))) + "[\177ÿ\200-\377]")) + ;; Range between normal chars and raw bytes: must be split to be parsed + ;; correctly by the Emacs regexp engine. + (should (equal (rx (any (0 . #x3fffff) word) (any (?G . #x3fff9a) word) + (any (?Ü . #x3ffff2) word)) + (concat "[\0-\x3fff7f\x80-\xff[:word:]]" + "[G-\x3fff7f\x80-\x9a[:word:]]" + "[Ü-\x3fff7f\x80-\xf2[:word:]]"))) + ;; As above but with ranges in string form. For historical reasons, + ;; we special-case ASCII-to-raw ranges to exclude non-ASCII unicode. + (should (equal (rx (any "\x00-\xff" alpha) (any "G-\x9a" alpha) + (any "Ü-\xf2" alpha)) + (concat "[\0-\x7f\x80-\xff[:alpha:]]" + "[G-\x7f\x80-\x9a[:alpha:]]" + "[Ü-\x3fff7f\x80-\xf2[:alpha:]]")))) (ert-deftest rx-any () (should (equal (rx (any ?A (?C . ?D) "F-H" "J-L" "M" "N-P" "Q" "RS")) @@ -138,7 +164,7 @@ (should (equal (rx (any "-]^" ascii) (not (any "-]^" ascii))) "[]^[:ascii:]-][^]^[:ascii:]-]")) (should (equal (rx (any "^" lower upper) (not (any "^" lower upper))) - "[[:lower:]^[:upper:]][^^[:lower:][:upper:]]")) + "[[:lower:][:upper:]^][^^[:lower:][:upper:]]")) (should (equal (rx (any "-" lower upper) (not (any "-" lower upper))) "[[:lower:][:upper:]-][^[:lower:][:upper:]-]")) (should (equal (rx (any "]" lower upper) (not (any "]" lower upper))) @@ -165,7 +191,10 @@ "[a[:space:][:digit:]]")) (should (equal (rx (not "\n") (not ?\n) (not (any "\n")) (not-char ?\n) (| (not (in "a\n")) (not (char ?\n (?b . ?b))))) - "....."))) + ".....")) + (should (equal (rx (or (in "g-k") (in "a-f") (or ?r (in "i-m" "n-q")))) + "[a-r]")) + ) (ert-deftest rx-pcase () (should (equal (pcase "i18n" ((rx (let x (+ digit))) (list 'ok x))) @@ -274,7 +303,7 @@ "^\\`\\'\\`\\'\\`\\'\\`\\'$")) (should (equal (rx point word-start word-end bow eow symbol-start symbol-end word-boundary not-word-boundary not-wordchar) - "\\=\\<\\>\\<\\>\\_<\\_>\\b\\B\\W")) + "\\=\\<\\>\\<\\>\\_<\\_>\\b\\B[^[:word:]]")) (should (equal (rx digit numeric num control cntrl) "[[:digit:]][[:digit:]][[:digit:]][[:cntrl:]][[:cntrl:]]")) (should (equal (rx hex-digit hex xdigit blank) @@ -296,7 +325,7 @@ (should (equal (rx (syntax whitespace) (syntax punctuation) (syntax word) (syntax symbol) (syntax open-parenthesis) (syntax close-parenthesis)) - "\\s-\\s.\\sw\\s_\\s(\\s)")) + "\\s-\\s.\\w\\s_\\s(\\s)")) (should (equal (rx (syntax string-quote) (syntax paired-delimiter) (syntax escape) (syntax character-quote) (syntax comment-start) (syntax comment-end) @@ -344,8 +373,9 @@ "\\B")) (should (equal (rx (not ascii) (not lower-case) (not wordchar)) "[^[:ascii:]][^[:lower:]][^[:word:]]")) - (should (equal (rx (not (syntax punctuation)) (not (syntax escape))) - "\\S.\\S\\")) + (should (equal (rx (not (syntax punctuation)) (not (syntax escape)) + (not (syntax word))) + "\\S.\\S\\\\W")) (should (equal (rx (not (category tone-mark)) (not (category lao))) "\\C4\\Co")) (should (equal (rx (not (not ascii)) (not (not (not (any "a-z"))))) @@ -381,7 +411,16 @@ (should (equal (rx (or (not (in "abc")) (not (char "bcd")))) "[^bc]")) (should (equal (rx (or "x" (? "yz"))) - "x\\|\\(?:yz\\)?"))) + "x\\|\\(?:yz\\)?")) + (should (equal (rx (or anychar (not anychar))) + "[^z-a]")) + (should (equal (rx (or (not (in "a-p")) (not (in "k-u")))) + "[^k-p]")) + (should (equal (rx (or (not (in "a-p")) word (not (in "k-u")))) + "[\0-jq-\x3fff7f\x80-\xff[:word:]]")) + (should (equal (rx (or (in "a-f" blank) (in "c-z") blank)) + "[a-z[:blank:]]")) + ) (ert-deftest rx-def-in-charset-or () (rx-let ((a (any "badc")) @@ -600,6 +639,57 @@ (rx-submatch-n '(group-n 3 (+ nonl) eol))) "\\(?3:.+$\\)"))) +;;; unit tests for internal functions + +(ert-deftest rx--interval-set-complement () + (should (equal (rx--interval-set-complement '()) + '((0 . #x3fffff)))) + (should (equal (rx--interval-set-complement '((10 . 20) (30 . 40))) + '((0 . 9) (21 . 29) (41 . #x3fffff)))) + (should (equal (rx--interval-set-complement '((0 . #x3fffff))) + '())) + (should (equal (rx--interval-set-complement + '((0 . 10) (20 . 20) (30 . #x3fffff))) + '((11 . 19) (21 . 29))))) + +(ert-deftest rx--interval-set-union () + (should (equal (rx--interval-set-union '() '()) '())) + (should (equal (rx--interval-set-union '() '((10 . 20) (30 . 40))) + '((10 . 20) (30 . 40)))) + (should (equal (rx--interval-set-union '((10 . 20) (30 . 40)) '()) + '((10 . 20) (30 . 40)))) + (should (equal (rx--interval-set-union '((5 . 15) (18 . 24) (32 . 40)) + '((10 . 20) (30 . 40) (50 . 60))) + '((5 . 24) (30 . 40) (50 . 60)))) + (should (equal (rx--interval-set-union '((10 . 20) (30 . 40) (50 . 60)) + '((0 . 9) (21 . 29) (41 . 50))) + '((0 . 60)))) + (should (equal (rx--interval-set-union '((10 . 20) (30 . 40)) + '((12 . 18) (28 . 42))) + '((10 . 20) (28 . 42)))) + (should (equal (rx--interval-set-union '((10 . 20) (30 . 40)) + '((0 . #x3fffff))) + '((0 . #x3fffff))))) + +(ert-deftest rx--interval-set-intersection () + (should (equal (rx--interval-set-intersection '() '()) '())) + (should (equal (rx--interval-set-intersection '() '((10 . 20) (30 . 40))) + '())) + (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40)) '()) + '())) + (should (equal (rx--interval-set-intersection '((5 . 15) (18 . 24) (32 . 40)) + '((10 . 20) (30 . 40) (50 . 60))) + '((10 . 15) (18 . 20) (32 . 40)))) + (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40) (50 . 60)) + '((0 . 9) (21 . 29) (41 . 50))) + '((50 . 50)))) + (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40)) + '((12 . 18) (28 . 42))) + '((12 . 18) (30 . 40)))) + (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40)) + '((0 . #x3fffff))) + '((10 . 20) (30 . 40))))) + (provide 'rx-tests) ;;; rx-tests.el ends here diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el index 516d095767f..596b47d2543 100644 --- a/test/lisp/emacs-lisp/shortdoc-tests.el +++ b/test/lisp/emacs-lisp/shortdoc-tests.el @@ -65,6 +65,49 @@ (when buf (kill-buffer buf)))))) +(defun shortdoc-tests--to-ascii (x) + "Translate Unicode arrows to ASCII for making the test work everywhere." + (cond ((consp x) + (cons (shortdoc-tests--to-ascii (car x)) + (shortdoc-tests--to-ascii (cdr x)))) + ((stringp x) + (thread-last x + (string-replace "⇒" "=>") + (string-replace "→" "->"))) + (t x))) + +(ert-deftest shortdoc-function-examples-test () + "Test the extraction of usage examples of some Elisp functions." + (should (equal '((list . "(delete 2 (list 1 2 3 4))\n => (1 3 4)\n (delete \"a\" (list \"a\" \"b\" \"c\" \"d\"))\n => (\"b\" \"c\" \"d\")")) + (shortdoc-tests--to-ascii + (shortdoc-function-examples 'delete)))) + (should (equal '((alist . "(assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)") + (list . "(assq 'b '((a . 1) (b . 2)))\n => (b . 2)")) + (shortdoc-tests--to-ascii + (shortdoc-function-examples 'assq)))) + (should (equal '((regexp . "(string-match-p \"^[fo]+\" \"foobar\")\n => 0")) + (shortdoc-tests--to-ascii + (shortdoc-function-examples 'string-match-p))))) + +(ert-deftest shortdoc-help-fns-examples-function-test () + "Test that `shortdoc-help-fns-examples-function' correctly prints ELisp function examples." + (with-temp-buffer + (shortdoc-help-fns-examples-function 'string-fill) + (should (equal "\n Examples:\n\n (string-fill \"Three short words\" 12)\n => \"Three short\\nwords\"\n (string-fill \"Long-word\" 3)\n => \"Long-word\"\n\n" + (shortdoc-tests--to-ascii + (buffer-substring-no-properties (point-min) (point-max))))) + (erase-buffer) + (shortdoc-help-fns-examples-function 'assq) + (should (equal "\n Examples:\n\n (assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)\n\n (assq 'b '((a . 1) (b . 2)))\n => (b . 2)\n\n" + (shortdoc-tests--to-ascii + (buffer-substring-no-properties (point-min) (point-max))))) + (erase-buffer) + (shortdoc-help-fns-examples-function 'string-trim) + (should (equal "\n Example:\n\n (string-trim \" foo \")\n => \"foo\"\n\n" + (shortdoc-tests--to-ascii + (buffer-substring-no-properties (point-min) + (point-max))))))) + (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 e4c270a114f..63d8fcd080c 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -709,14 +709,15 @@ [(raise 0.5) (height 2.0)])) (should (equal (get-text-property 9 'display) '(raise 0.5)))) (with-temp-buffer - (should (equal (let ((str "some useless string")) - (add-display-text-property 4 8 'height 2.0 str) - (add-display-text-property 2 12 'raise 0.5 str) - str) - #("some useless string" - 2 4 (display (raise 0.5)) - 4 8 (display ((raise 0.5) (height 2.0))) - 8 12 (display (raise 0.5))))))) + (should (equal-including-properties + (let ((str (copy-sequence "some useless string"))) + (add-display-text-property 4 8 'height 2.0 str) + (add-display-text-property 2 12 'raise 0.5 str) + str) + #("some useless string" + 2 4 (display (raise 0.5)) + 4 8 (display ((raise 0.5) (height 2.0))) + 8 12 (display (raise 0.5))))))) (ert-deftest subr-x-named-let () (let ((funs ())) |