diff options
Diffstat (limited to 'test/lisp/emacs-lisp')
37 files changed, 1780 insertions, 572 deletions
diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el index a9a881987c0..911a5f0c7b1 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -1,4 +1,4 @@ -;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t; coding: utf-8; -*- +;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t -*- ;; Copyright (C) 2019-2021 Free Software Foundation, Inc. @@ -23,44 +23,50 @@ (require 'bindat) (require 'cl-lib) -(defvar header-bindat-spec - '((dest-ip ip) +(bindat-defmacro ip () "An IPv4 address" '(vec 4 byte)) + +(defconst header-bindat-spec + (bindat-type + (dest-ip ip) (src-ip ip) - (dest-port u16) - (src-port u16))) + (dest-port uint 16) + (src-port uint 16))) -(defvar data-bindat-spec - '((type u8) +(defconst data-bindat-spec + (bindat-type + (type u8) (opcode u8) - (length u16r) ;; little endian order + (length uintr 16) ;; little endian order (id strz 8) - (data vec (length)) - (align 4))) + (data vec length) + (_ align 4))) + -(defvar packet-bindat-spec - '((header struct header-bindat-spec) +(defconst packet-bindat-spec + (bindat-type + (header type header-bindat-spec) (items u8) - (fill 3) - (item repeat (items) - (struct data-bindat-spec)))) + (_ fill 3) + (item repeat items + (_ type data-bindat-spec)))) -(defvar struct-bindat +(defconst struct-bindat '((header (dest-ip . [192 168 1 100]) (src-ip . [192 168 1 101]) (dest-port . 284) (src-port . 5408)) (items . 2) - (item ((data . [1 2 3 4 5]) - (id . "ABCDEF") - (length . 5) + (item ((type . 2) (opcode . 3) - (type . 2)) - ((data . [6 7 8 9 10 11 12]) - (id . "BCDEFG") - (length . 7) + (length . 5) + (id . "ABCDEF") + (data . [1 2 3 4 5])) + ((type . 1) (opcode . 4) - (type . 1))))) + (length . 7) + (id . "BCDEFG") + (data . [6 7 8 9 10 11 12]))))) (ert-deftest bindat-test-pack () (should (equal @@ -74,27 +80,7 @@ (should (equal (bindat-unpack packet-bindat-spec (bindat-pack packet-bindat-spec struct-bindat)) - '((item - ((data . - [1 2 3 4 5]) - (id . "ABCDEF") - (length . 5) - (opcode . 3) - (type . 2)) - ((data . - [6 7 8 9 10 11 12]) - (id . "BCDEFG") - (length . 7) - (opcode . 4) - (type . 1))) - (items . 2) - (header - (src-port . 5408) - (dest-port . 284) - (src-ip . - [192 168 1 101]) - (dest-ip . - [192 168 1 100])))))) + struct-bindat))) (ert-deftest bindat-test-pack/multibyte-string-fails () (should-error (bindat-pack nil nil "ö"))) @@ -118,4 +104,62 @@ (should (equal (bindat-ip-to-string [192 168 0 1]) "192.168.0.1")) (should (equal (bindat-ip-to-string "\300\250\0\1") "192.168.0.1"))) +(defconst bindat-test--int-websocket-type + (bindat-type + :pack-var value + (n1 u8 + :pack-val (if (< value 126) value (if (< value 65536) 126 127))) + (n2 uint (pcase n1 (127 64) (126 16) (_ 0)) + :pack-val value) + :unpack-val (if (< n1 126) n1 n2))) + +(ert-deftest bindat-test--pack-val () + ;; This is intended to test the :(un)pack-val feature that offers + ;; control over the unpacked representation of the data. + (dolist (n '(0 42 125 126 127 128 150 255 5000 65535 65536 8769786876)) + (should + (equal (bindat-unpack bindat-test--int-websocket-type + (bindat-pack bindat-test--int-websocket-type n)) + n)))) + +(ert-deftest bindat-test--sint () + (dotimes (kind 32) + (let ((bitlen (* 8 (/ kind 2))) + (r (zerop (% kind 2)))) + (dotimes (_ 100) + (let* ((n (random (ash 1 bitlen))) + (i (- n (ash 1 (1- bitlen))))) + (should (equal (bindat-unpack + (bindat-type sint bitlen r) + (bindat-pack (bindat-type sint bitlen r) 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)) + i)))))))) + +(defconst bindat-test--LEB128 + (bindat-type + letrec ((loop + (struct :pack-var n + (head u8 + :pack-val (+ (logand n 127) (if (> n 127) 128 0))) + (tail if (< head 128) (unit 0) loop + :pack-val (ash n -7)) + :unpack-val (+ (logand head 127) (ash tail 7))))) + loop)) + +(ert-deftest bindat-test--recursive () + (dotimes (n 10) + (let ((max (ash 1 (* n 10)))) + (dotimes (_ 10) + (let ((n (random max))) + (should (equal (bindat-unpack bindat-test--LEB128 + (bindat-pack bindat-test--LEB128 n)) + n))))))) + ;;; bindat-tests.el ends here diff --git a/test/lisp/emacs-lisp/bytecomp-resources/bc-test-alpha.el b/test/lisp/emacs-lisp/bytecomp-resources/bc-test-alpha.el new file mode 100644 index 00000000000..6997d91b26a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/bc-test-alpha.el @@ -0,0 +1,9 @@ +;;; -*- lexical-binding: t -*- + +(require 'bc-test-beta) + +(defun bc-test-alpha-f (x) + (let ((y nil)) + (list y (bc-test-beta-f x)))) + +(provide 'bc-test-alpha) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/bc-test-beta.el b/test/lisp/emacs-lisp/bytecomp-resources/bc-test-beta.el new file mode 100644 index 00000000000..9205a13d7d5 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/bc-test-beta.el @@ -0,0 +1,6 @@ +;;; -*- lexical-binding: t -*- + +(defsubst bc-test-beta-f (y) + y) + +(provide 'bc-test-beta) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs-defsubst.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs-defsubst.el new file mode 100644 index 00000000000..3a29128cf3a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs-defsubst.el @@ -0,0 +1,5 @@ +;;; -*- lexical-binding: t -*- +(defsubst warn-callargs-defsubst-f1 (_x) + nil) +(defun warn-callargs-defsubst-f2 () + (warn-callargs-defsubst-f1 1 2)) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index bc623d3efca..80003c264a2 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -41,7 +41,7 @@ "Identity, but hidden from some optimisations." x) -(defconst byte-opt-testsuite-arith-data +(defconst bytecomp-tests--test-cases '( ;; some functional tests (let ((a most-positive-fixnum) (b 1) (c 1.0)) (+ a b c)) @@ -364,17 +364,17 @@ '((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c) (t c) (x "a") (x "c") (x c) (x d) (x e))) - (mapcar (lambda (x) (cond ((member '(a . b) x) 1) - ((equal x '(c)) 2))) + (mapcar (lambda (x) (ignore-errors (cond ((member '(a . b) x) 1) + ((equal x '(c)) 2)))) '(((a . b)) a b (c) (d))) - (mapcar (lambda (x) (cond ((memq '(a . b) x) 1) - ((equal x '(c)) 2))) + (mapcar (lambda (x) (ignore-errors (cond ((memq '(a . b) x) 1) + ((equal x '(c)) 2)))) '(((a . b)) a b (c) (d))) - (mapcar (lambda (x) (cond ((member '(a b) x) 1) - ((equal x '(c)) 2))) + (mapcar (lambda (x) (ignore-errors (cond ((member '(a b) x) 1) + ((equal x '(c)) 2)))) '(((a b)) a b (c) (d))) - (mapcar (lambda (x) (cond ((memq '(a b) x) 1) - ((equal x '(c)) 2))) + (mapcar (lambda (x) (ignore-errors (cond ((memq '(a b) x) 1) + ((equal x '(c)) 2)))) '(((a b)) a b (c) (d))) (assoc 'b '((a 1) (b 2) (c 3))) @@ -396,7 +396,7 @@ x) (let ((x 1) (bytecomp-test-var 2) (y 3)) - (list x bytecomp-test-var (bytecomp-get-test-var) y)) + (list x bytecomp-test-var (bytecomp-test-get-var) y)) (progn (defvar d) @@ -430,71 +430,162 @@ (list s x i)) (let ((x 2)) - (list (or (bytecomp-identity 'a) (setq x 3)) x))) - "List of expression for test. -Each element will be executed by interpreter and with -bytecompiled code, and their results compared.") + (list (or (bytecomp-test-identity 'a) (setq x 3)) x)) + + (mapcar (lambda (b) + (let ((a nil)) + (+ 0 + (progn + (setq a b) + (setq b 1) + a)))) + '(10)) + + (let* ((x 1) + (y (condition-case x + (/ 1 0) + (arith-error x)))) + (list x y)) -(defun bytecomp-check-1 (pat) - "Return non-nil if PAT is the same whether directly evalled or compiled." - (let ((warning-minimum-log-level :emergency) - (byte-compile-warnings nil) - (v0 (condition-case err - (eval pat) - (error (list 'bytecomp-check-error (car err))))) - (v1 (condition-case err - (funcall (byte-compile (list 'lambda nil pat))) - (error (list 'bytecomp-check-error (car err)))))) - (equal v0 v1))) - -(put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1) - -(defun bytecomp-explain-1 (pat) - (let ((v0 (condition-case err - (eval pat) - (error (list 'bytecomp-check-error (car err))))) - (v1 (condition-case err - (funcall (byte-compile (list 'lambda nil pat))) - (error (list 'bytecomp-check-error (car err)))))) - (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." - pat v0 v1))) - -(ert-deftest bytecomp-tests () - "Test the Emacs byte compiler." - (dolist (pat byte-opt-testsuite-arith-data) - (should (bytecomp-check-1 pat)))) - -(defun test-byte-opt-arithmetic (&optional arg) - "Unit test for byte-opt arithmetic operations. -Subtests signal errors if something goes wrong." - (interactive "P") - (switch-to-buffer (generate-new-buffer "*Font Pase Test*")) + (funcall + (condition-case x + (/ 1 0) + (arith-error (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + + ;; No error, no success handler. + (condition-case x + (list 42) + (error (cons 'bad x))) + ;; Error, no success handler. + (condition-case x + (/ 1 0) + (error (cons 'bad x))) + ;; No error, success handler. + (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (cons 'good x))) + ;; Error, success handler. + (condition-case x + (/ 1 0) + (error (cons 'bad x)) + (:success (cons 'good x))) + ;; Verify that the success code is not subject to the error handlers. + (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (/ (car x) 0))) + ;; Check variable scoping on success. + (let ((x 2)) + (condition-case x + (list x) + (error (list 'bad x)) + (:success (list 'good x)))) + ;; Check variable scoping on failure. + (let ((x 2)) + (condition-case x + (/ 1 0) + (error (list 'bad x)) + (:success (list 'good x)))) + ;; Check capture of mutated result variable. + (funcall + (condition-case x + 3 + (:success (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + ;; Check for-effect context, on error. + (let ((f (lambda (x) + (condition-case nil + (/ 1 0) + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + ;; Check for-effect context, on success. + (let ((f (lambda (x) + (condition-case nil + nil + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + + ;; Check `not' in cond switch (bug#49746). + (mapcar (lambda (x) (cond ((equal x "a") 1) + ((member x '("b" "c")) 2) + ((not x) 3))) + '("a" "b" "c" "d" nil)) + + ;; `let' and `let*' optimisations with body being constant or variable + (let* (a + (b (progn (setq a (cons 1 a)) 2)) + (c (1+ b)) + (d (list a c))) + d) + (let ((a nil)) + (let ((b (progn (setq a (cons 1 a)) 2)) + (c (progn (setq a (cons 3 a)))) + (d (list a))) + d)) + (let* ((_a 1) + (_b 2)) + 'z) + (let ((_a 1) + (_b 2)) + 'z) + ) + "List of expressions for cross-testing interpreted and compiled code.") + +(defconst bytecomp-tests--test-cases-lexbind-only + `( + ;; This would infloop (and exhaust stack) with dynamic binding. + (let ((f #'car)) + (let ((f (lambda (x) (cons (funcall f x) (cdr x))))) + (funcall f '(1 . 2)))) + ) + "List of expressions for cross-testing interpreted and compiled code. +These are only tested with lexical binding.") + +(defun bytecomp-tests--eval-interpreted (form) + "Evaluate FORM using the Lisp interpreter, returning errors as a +special value." + (condition-case err + (eval form lexical-binding) + (error (list 'bytecomp-check-error (car err))))) + +(defun bytecomp-tests--eval-compiled (form) + "Evaluate FORM using the Lisp byte-code compiler, returning errors as a +special value." (let ((warning-minimum-log-level :emergency) - (byte-compile-warnings nil) - (pass-face '((t :foreground "green"))) - (fail-face '((t :foreground "red"))) - (print-escape-nonascii t) - (print-escape-newlines t) - (print-quoted t) - v0 v1) - (dolist (pat byte-opt-testsuite-arith-data) - (condition-case err - (setq v0 (eval pat)) - (error (setq v0 (list 'bytecomp-check-error (car err))))) - (condition-case err - (setq v1 (funcall (byte-compile (list 'lambda nil pat)))) - (error (setq v1 (list 'bytecomp-check-error (car err))))) - (insert (format "%s" pat)) - (indent-to-column 65) - (if (equal v0 v1) - (insert (propertize "OK" 'face pass-face)) - (insert (propertize "FAIL\n" 'face fail-face)) - (indent-to-column 55) - (insert (propertize (format "[%s] vs [%s]" v0 v1) - 'face fail-face))) - (insert "\n")))) + (byte-compile-warnings nil)) + (condition-case err + (funcall (byte-compile (list 'lambda nil form))) + (error (list 'bytecomp-check-error (car err)))))) + +(ert-deftest bytecomp-tests-lexbind () + "Check that various expressions behave the same when interpreted and +byte-compiled. Run with lexical binding." + (let ((lexical-binding t)) + (dolist (form (append bytecomp-tests--test-cases-lexbind-only + bytecomp-tests--test-cases)) + (ert-info ((prin1-to-string form) :prefix "form: ") + (should (equal (bytecomp-tests--eval-interpreted form) + (bytecomp-tests--eval-compiled form))))))) + +(ert-deftest bytecomp-tests-dynbind () + "Check that various expressions behave the same when interpreted and +byte-compiled. Run with dynamic binding." + (let ((lexical-binding nil)) + (dolist (form bytecomp-tests--test-cases) + (ert-info ((prin1-to-string form) :prefix "form: ") + (should (equal (bytecomp-tests--eval-interpreted form) + (bytecomp-tests--eval-compiled form))))))) (defun test-byte-comp-compile-and-load (compile &rest forms) + (declare (indent 1)) (let ((elfile nil) (elcfile nil)) (unwind-protect @@ -513,7 +604,6 @@ Subtests signal errors if something goes wrong." (load elfile nil 'nomessage)) (when elfile (delete-file elfile)) (when elcfile (delete-file elcfile))))) -(put 'test-byte-comp-compile-and-load 'lisp-indent-function 1) (ert-deftest test-byte-comp-macro-expansion () (test-byte-comp-compile-and-load t @@ -584,8 +674,8 @@ Subtests signal errors if something goes wrong." `(with-current-buffer (get-buffer-create "*Compile-Log*") (let ((inhibit-read-only t)) (erase-buffer)) (byte-compile ,@form) - (ert-info ((buffer-string) :prefix "buffer: ") - (should (re-search-forward ,re-warning))))) + (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") + (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning)))))) (ert-deftest bytecomp-warn-wrong-args () (bytecomp--with-warning-test "remq.*3.*2" @@ -611,12 +701,13 @@ Subtests signal errors if something goes wrong." (defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse) `(ert-deftest ,(intern (format "bytecomp/%s" file)) () - :expected-result ,(if reverse :failed :passed) (with-current-buffer (get-buffer-create "*Compile-Log*") (let ((inhibit-read-only t)) (erase-buffer)) (byte-compile-file ,(ert-resource-file file)) (ert-info ((buffer-string) :prefix "buffer: ") - (should (re-search-forward ,re-warning)))))) + (,(if reverse 'should-not 'should) + (re-search-forward ,(string-replace " " "[ \n]+" re-warning) + nil t)))))) (bytecomp--define-warning-file-test "error-lexical-var-with-add-hook.el" "add-hook.*lexical var") @@ -642,6 +733,9 @@ Subtests signal errors if something goes wrong." (bytecomp--define-warning-file-test "warn-callargs.el" "with 2 arguments, but accepts only 1") +(bytecomp--define-warning-file-test "warn-callargs-defsubst.el" + "with 2 arguments, but accepts only 1") + (bytecomp--define-warning-file-test "warn-defcustom-nogroup.el" "fails to specify containing group") @@ -658,10 +752,10 @@ Subtests signal errors if something goes wrong." "free.*foo") (bytecomp--define-warning-file-test "warn-free-variable-reference.el" - "free.*bar") + "free variable .bar") (bytecomp--define-warning-file-test "warn-make-variable-buffer-local.el" - "make-variable-buffer-local.*not called at toplevel") + "make-variable-buffer-local. not called at toplevel") (bytecomp--define-warning-file-test "warn-interactive-only.el" "next-line.*interactive use only.*forward-line") @@ -670,19 +764,19 @@ Subtests signal errors if something goes wrong." "malformed interactive spec") (bytecomp--define-warning-file-test "warn-obsolete-defun.el" - "foo-obsolete.*obsolete function.*99.99") + "foo-obsolete. is an obsolete function (as of 99.99)") (defvar bytecomp--tests-obsolete-var nil) (make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99") (bytecomp--define-warning-file-test "warn-obsolete-hook.el" - "bytecomp--tests-obs.*obsolete[^z-a]*99.99") + "bytecomp--tests-obsolete-var. is an obsolete variable (as of 99.99)") (bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el" "foo-obs.*obsolete.*99.99" t) (bytecomp--define-warning-file-test "warn-obsolete-variable.el" - "bytecomp--tests-obs.*obsolete[^z-a]*99.99") + "bytecomp--tests-obsolete-var. is an obsolete variable (as of 99.99)") (bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el" "bytecomp--tests-obs.*obsolete.*99.99" t) @@ -713,64 +807,64 @@ Subtests signal errors if something goes wrong." (bytecomp--define-warning-file-test "warn-wide-docstring-autoload.el" - "autoload.*foox.*wider than.*characters") + "autoload .foox. docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-custom-declare-variable.el" - "custom-declare-variable.*foo.*wider than.*characters") + "custom-declare-variable .foo. docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-defalias.el" - "defalias.*foo.*wider than.*characters") + "defalias .foo. docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-defconst.el" - "defconst.*foo.*wider than.*characters") + "defconst .foo-bar. docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-define-abbrev-table.el" - "define-abbrev.*foo.*wider than.*characters") + "define-abbrev-table .foo. docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-define-obsolete-function-alias.el" - "defalias.*foo.*wider than.*characters") + "defalias .foo. docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-define-obsolete-variable-alias.el" - "defvaralias.*foo.*wider than.*characters") + "defvaralias .foo. docstring wider than .* characters") ;; TODO: We don't yet issue warnings for defuns. (bytecomp--define-warning-file-test "warn-wide-docstring-defun.el" - "wider than.*characters" 'reverse) + "wider than .* characters" 'reverse) (bytecomp--define-warning-file-test "warn-wide-docstring-defvar.el" - "defvar.*foo.*wider than.*characters") + "defvar .foo-bar. docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-defvaralias.el" - "defvaralias.*foo.*wider than.*characters") + "defvaralias .foo-bar. docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-ignore-fill-column.el" - "defvar.*foo.*wider than.*characters" 'reverse) + "defvar .foo-bar. docstring wider than .* characters" 'reverse) (bytecomp--define-warning-file-test "warn-wide-docstring-ignore-override.el" - "defvar.*foo.*wider than.*characters" 'reverse) + "defvar .foo-bar. docstring wider than .* characters" 'reverse) (bytecomp--define-warning-file-test "warn-wide-docstring-ignore.el" - "defvar.*foo.*wider than.*characters" 'reverse) + "defvar .foo-bar. docstring wider than .* characters" 'reverse) (bytecomp--define-warning-file-test "warn-wide-docstring-multiline-first.el" - "defvar.*foo.*wider than.*characters") + "defvar .foo-bar. docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-multiline.el" - "defvar.*foo.*wider than.*characters") + "defvar .foo-bar. docstring wider than .* characters") (bytecomp--define-warning-file-test "nowarn-inline-after-defvar.el" @@ -813,47 +907,6 @@ Subtests signal errors if something goes wrong." (defun def () (m)))) (should (equal (funcall 'def) 4))) -(defconst bytecomp-lexbind-tests - `( - (let ((f #'car)) - (let ((f (lambda (x) (cons (funcall f x) (cdr x))))) - (funcall f '(1 . 2)))) - ) - "List of expression for test. -Each element will be executed by interpreter and with -bytecompiled code, and their results compared.") - -(defun bytecomp-lexbind-check-1 (pat) - "Return non-nil if PAT is the same whether directly evalled or compiled." - (let ((warning-minimum-log-level :emergency) - (byte-compile-warnings nil) - (v0 (condition-case err - (eval pat t) - (error (list 'bytecomp-check-error (car err))))) - (v1 (condition-case err - (funcall (let ((lexical-binding t)) - (byte-compile `(lambda nil ,pat)))) - (error (list 'bytecomp-check-error (car err)))))) - (equal v0 v1))) - -(put 'bytecomp-lexbind-check-1 'ert-explainer 'bytecomp-lexbind-explain-1) - -(defun bytecomp-lexbind-explain-1 (pat) - (let ((v0 (condition-case err - (eval pat t) - (error (list 'bytecomp-check-error (car err))))) - (v1 (condition-case err - (funcall (let ((lexical-binding t)) - (byte-compile (list 'lambda nil pat)))) - (error (list 'bytecomp-check-error (car err)))))) - (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." - pat v0 v1))) - -(ert-deftest bytecomp-lexbind-tests () - "Test the Emacs byte compiler lexbind handling." - (dolist (pat bytecomp-lexbind-tests) - (should (bytecomp-lexbind-check-1 pat)))) - (defmacro bytecomp-tests--with-temp-file (file-name-var &rest body) (declare (indent 1)) (cl-check-type file-name-var symbol) @@ -1168,6 +1221,151 @@ mountpoint (Bug#44631)." (with-demoted-errors "Error cleaning up directory: %s" (delete-directory directory :recursive))))) +(defun bytecomp-tests--get-vars () + (list (ignore-errors (symbol-value 'bytecomp-tests--var1)) + (ignore-errors (symbol-value 'bytecomp-tests--var2)))) + +(ert-deftest bytecomp-local-defvar () + "Check that local `defvar' declarations work correctly, both +interpreted and compiled." + (let ((lexical-binding t)) + (let ((fun '(lambda () + (defvar bytecomp-tests--var1) + (let ((bytecomp-tests--var1 'a) ; dynamic + (bytecomp-tests--var2 'b)) ; still lexical + (ignore bytecomp-tests--var2) ; avoid warning + (bytecomp-tests--get-vars))))) + (should (listp fun)) ; Guard against overzealous refactoring! + (should (equal (funcall (eval fun t)) '(a nil))) + (should (equal (funcall (byte-compile fun)) '(a nil))) + ) + + ;; `progn' does not constitute a lexical scope for `defvar' (bug#46387). + (let ((fun '(lambda () + (progn + (defvar bytecomp-tests--var1) + (defvar bytecomp-tests--var2)) + (let ((bytecomp-tests--var1 'c) + (bytecomp-tests--var2 'd)) + (bytecomp-tests--get-vars))))) + (should (listp fun)) + (should (equal (funcall (eval fun t)) '(c d))) + (should (equal (funcall (byte-compile fun)) '(c d)))))) + +(ert-deftest bytecomp-reify-function () + "Check that closures that modify their bound variables are +compiled correctly." + (cl-letf ((lexical-binding t) + ((symbol-function 'counter) nil)) + (let ((x 0)) + (defun counter () (cl-incf x)) + (should (equal (counter) 1)) + (should (equal (counter) 2)) + ;; byte compiling should not cause counter to always return the + ;; same value (bug#46834) + (byte-compile 'counter) + (should (equal (counter) 3)) + (should (equal (counter) 4))) + (let ((x 0)) + (let ((x 1)) + (defun counter () x) + (should (equal (counter) 1)) + ;; byte compiling should not cause the outer binding to shadow + ;; the inner one (bug#46834) + (byte-compile 'counter) + (should (equal (counter) 1)))))) + +(ert-deftest bytecomp-string-vs-docstring () + ;; Don't confuse a string return value for a docstring. + (let ((lexical-binding t)) + (should (equal (funcall (byte-compile '(lambda (x) "foo")) 'dummy) "foo")))) + +(ert-deftest bytecomp-condition-case-success () + ;; No error, no success handler. + (should (equal (condition-case x + (list 42) + (error (cons 'bad x))) + '(42))) + ;; Error, no success handler. + (should (equal (condition-case x + (/ 1 0) + (error (cons 'bad x))) + '(bad arith-error))) + ;; No error, success handler. + (should (equal (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (cons 'good x))) + '(good 42))) + ;; Error, success handler. + (should (equal (condition-case x + (/ 1 0) + (error (cons 'bad x)) + (:success (cons 'good x))) + '(bad arith-error))) + ;; Verify that the success code is not subject to the error handlers. + (should-error (condition-case x + (list 42) + (error (cons 'bad x)) + (:success (/ (car x) 0))) + :type 'arith-error) + ;; Check variable scoping. + (let ((x 2)) + (should (equal (condition-case x + (list x) + (error (list 'bad x)) + (:success (list 'good x))) + '(good (2)))) + (should (equal (condition-case x + (/ 1 0) + (error (list 'bad x)) + (:success (list 'good x))) + '(bad (arith-error))))) + ;; Check capture of mutated result variable. + (should (equal (funcall + (condition-case x + 3 + (:success (prog1 (lambda (y) (+ y x)) + (setq x 10)))) + 4) + 14)) + ;; Check for-effect context, on error. + (should (equal (let ((f (lambda (x) + (condition-case nil + (/ 1 0) + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + 4)) + ;; Check for-effect context, on success. + (should (equal (let ((f (lambda (x) + (condition-case nil + nil + (error 'bad) + (:success 'good)) + (1+ x)))) + (funcall f 3)) + 4))) + +(declare-function bc-test-alpha-f (ert-resource-file "bc-test-alpha.el")) + +(ert-deftest bytecomp-defsubst () + ;; Check that lexical variables don't leak into inlined code. See + ;; https://lists.gnu.org/archive/html/emacs-devel/2021-05/msg01227.html + + ;; First, remove any trace of the functions and package defined: + (fmakunbound 'bc-test-alpha-f) + (fmakunbound 'bc-test-beta-f) + (setq features (delq 'bc-test-beta features)) + ;; Byte-compile one file that uses a function from another file that isn't + ;; compiled. + (let ((file (ert-resource-file "bc-test-alpha.el")) + (load-path (cons (ert-resource-directory) load-path))) + (byte-compile-file file) + (load-file (concat file "c")) + (should (equal (bc-test-alpha-f 'a) '(nil a))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 517373386e3..5aeed0cc155 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -182,7 +182,14 @@ (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result))) (ert-deftest cconv-convert-lambda-lifted () - "Bug#30872." + ;; Verify that lambda-lifting is actually performed at all. + (should (equal (cconv-closure-convert + '#'(lambda (x) (let ((f #'(lambda () (+ x 1)))) + (funcall f)))) + '#'(lambda (x) (let ((f #'(lambda (x) (+ x 1)))) + (funcall f x))))) + + ;; Bug#30872. (should (equal (funcall (byte-compile diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el index 9552bf0e397..276530fb4d3 100644 --- a/test/lisp/emacs-lisp/check-declare-tests.el +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -106,11 +106,11 @@ (let ((res (buffer-string))) ;; Don't care too much about the format of the output, but ;; check that key information is present. - (should (string-match-p "foo-file" res)) - (should (string-match-p "foo-fun" res)) - (should (string-match-p "bar-file" res)) - (should (string-match-p "it wasn't" res)) - (should (string-match-p "999" res)))))) + (should (string-search "foo-file" res)) + (should (string-search "foo-fun" res)) + (should (string-search "bar-file" res)) + (should (string-search "it wasn't" res)) + (should (string-search "999" res)))))) (provide 'check-declare-tests) ;;; check-declare-tests.el ends here diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el index cf7baf4ce44..2a1d8b27636 100644 --- a/test/lisp/emacs-lisp/checkdoc-tests.el +++ b/test/lisp/emacs-lisp/checkdoc-tests.el @@ -49,52 +49,34 @@ (with-temp-buffer (emacs-lisp-mode) ;; this method matches if A is the symbol `smthg' and if b is a list: - (insert "(cl-defmethod foo ((a (eql smthg)) (b list)) \"Return A+B.\")") + (insert "(cl-defmethod foo ((a (eql 'smthg)) (b list)) \"Return A+B.\")") (checkdoc-defun))) -(ert-deftest checkdoc-cl-defun-with-key-ok () - "Checkdoc should be happy with a cl-defun using &key." +(ert-deftest checkdoc-cl-defmethod-qualified-ok () + "Checkdoc should be happy with a `cl-defmethod' using qualifiers." (with-temp-buffer (emacs-lisp-mode) - (insert "(cl-defun foo (&key a (b 27)) \"Return :A+:B.\")") + (insert "(cl-defmethod test :around ((a (eql 'smthg))) \"Return A.\")") (checkdoc-defun))) -(ert-deftest checkdoc-cl-defun-with-allow-other-keys-ok () - "Checkdoc should be happy with a cl-defun using &allow-other-keys." +(ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-ok () + "Checkdoc should be happy with a :extra qualified `cl-defmethod'." (with-temp-buffer (emacs-lisp-mode) - (insert "(cl-defun foo (&key a &allow-other-keys) \"Return :A.\")") - (checkdoc-defun))) + (insert "(cl-defmethod foo :extra \"foo\" ((a (eql 'smthg))) \"Return A.\")") + (checkdoc-defun)) -(ert-deftest checkdoc-cl-defun-with-default-optional-value-ok () - "Checkdoc should be happy with a cl-defun using default values for optional args." (with-temp-buffer (emacs-lisp-mode) - ;; B is optional and equals 1+a if not provided. HAS-BS is non-nil - ;; if B was provided in the call: - (insert "(cl-defun foo (a &optional (b (1+ a) has-bs)) \"Return A + B.\")") + (insert + "(cl-defmethod foo :extra \"foo\" :after ((a (eql 'smthg))) \"Return A.\")") (checkdoc-defun))) -(ert-deftest checkdoc-cl-defun-with-destructuring-ok () - "Checkdoc should be happy with a cl-defun destructuring its arguments." +(ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-and-nil-args-ok () + "Checkdoc should be happy with a 0-arity :extra qualified `cl-defmethod'." (with-temp-buffer (emacs-lisp-mode) - (insert "(cl-defun foo ((a b &optional c) d) \"Return A+B+C+D.\")") - (checkdoc-defun))) - -(ert-deftest checkdoc-cl-defmethod-ok () - "Checkdoc should be happy with a simple correct cl-defmethod." - (with-temp-buffer - (emacs-lisp-mode) - (insert "(cl-defmethod foo (a) \"Return A.\")") - (checkdoc-defun))) - -(ert-deftest checkdoc-cl-defmethod-with-types-ok () - "Checkdoc should be happy with a cl-defmethod using types." - (with-temp-buffer - (emacs-lisp-mode) - ;; this method matches if A is the symbol `smthg' and if b is a list: - (insert "(cl-defmethod foo ((a (eql smthg)) (b list)) \"Return A+B.\")") + (insert "(cl-defmethod foo :extra \"foo\" () \"Return A.\")") (checkdoc-defun))) (ert-deftest checkdoc-cl-defun-with-key-ok () diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el index f3c308725ac..91f0a1e2014 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -4,18 +4,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 4a01623cb88..dd7511e9afe 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -56,7 +56,14 @@ (should (equal (cl--generic-1 'a nil) '(a))) (should (equal (cl--generic-1 4 nil) '("quatre" 4))) (should (equal (cl--generic-1 5 nil) '("cinq" 5))) - (should (equal (cl--generic-1 6 nil) '("six" a)))) + (should (equal (cl--generic-1 6 nil) '("six" a))) + (defvar cl--generic-fooval 41) + (cl-defmethod cl--generic-1 ((_x (eql (+ cl--generic-fooval 1))) _y) + "forty-two") + (cl-defmethod cl--generic-1 (_x (_y (eql 42))) + "FORTY-TWO") + (should (equal (cl--generic-1 42 nil) "forty-two")) + (should (equal (cl--generic-1 nil 42) "FORTY-TWO"))) (cl-defstruct cl-generic-struct-parent a b) (cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c) @@ -269,9 +276,7 @@ Edebug symbols (Bug#42672)." (when (memq name instrumented-names) (error "Duplicate definition of `%s'" name)) (push name instrumented-names) - (edebug-new-definition name))) - ;; Make generated symbols reproducible. - (gensym-counter 10000)) + (edebug-new-definition name)))) (eval-buffer) (should (equal (reverse instrumented-names) @@ -280,11 +285,11 @@ Edebug symbols (Bug#42672)." ;; FIXME: We'd rather have names such as ;; `cl-defgeneric/edebug/method/1 ((_ number))', but ;; that requires further changes to Edebug. - (list (intern "cl-generic-:method@10000 ((_ number))") - (intern "cl-generic-:method@10001 ((_ string))") - (intern "cl-generic-:method@10002 :around ((_ number))") + (list (intern "cl-defgeneric/edebug/method/1 (number)") + (intern "cl-defgeneric/edebug/method/1 (string)") + (intern "cl-defgeneric/edebug/method/1 :around (number)") 'cl-defgeneric/edebug/method/1 - (intern "cl-generic-:method@10003 ((_ number))") + (intern "cl-defgeneric/edebug/method/2 (number)") 'cl-defgeneric/edebug/method/2)))))) (provide 'cl-generic-tests) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 065ca4fa651..a5ec62b9c42 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -4,18 +4,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index bcd63f73a3c..f4e2e46a019 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -4,18 +4,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -617,11 +617,37 @@ collection clause." (cl-labels ((len (xs) (if xs (1+ (len (cdr xs))) 0))) (should (equal (len (make-list 42 t)) 42))) - ;; Simple tail-recursive function. - (cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n))) - (should (equal (len (make-list 42 t) 0) 42)) - ;; Should not bump into stack depth limits. - (should (equal (len (make-list 42000 t) 0) 42000))) + (let ((list-42 (make-list 42 t)) + (list-42k (make-list 42000 t))) + + (cl-labels + ;; Simple tail-recursive function. + ((len (xs n) (if xs (len (cdr xs) (1+ n)) n)) + ;; Slightly obfuscated version to exercise tail calls from + ;; `let', `progn', `and' and `or'. + (len2 (xs n) (or (and (not xs) n) + (let (n1) + (and xs + (progn (setq n1 (1+ n)) + (len2 (cdr xs) n1)))))) + ;; Tail calls in error and success handlers. + (len3 (xs n) + (if xs + (condition-case k + (/ 1 (logand n 1)) + (arith-error (len3 (cdr xs) (1+ n))) + (:success (len3 (cdr xs) (+ n k)))) + n))) + (should (equal (len nil 0) 0)) + (should (equal (len2 nil 0) 0)) + (should (equal (len3 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 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)))) ;; Check that non-recursive functions are handled more efficiently. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) @@ -633,4 +659,9 @@ collection clause." #'len)) (`(function (lambda (,_ ,_) . ,_)) t)))) +(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)) + '(1 2)))) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el new file mode 100644 index 00000000000..59e1b6982e1 --- /dev/null +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -0,0 +1,233 @@ +;;; comp-cstr-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; Author: Andrea Corallo <akrl@sdf.org> + +;; 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: + +;; Unit tests for lisp/emacs-lisp/comp-cstr.el + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'comp-cstr) + +(cl-eval-when (compile eval load) + + (defun comp-cstr-test-ts (type-spec) + "Create a constraint from TYPE-SPEC and convert it back to type specifier." + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec)))) + + (defun comp-cstr-typespec-test (number type-spec expected-type-spec) + `(ert-deftest ,(intern (concat "comp-cstr-test-" (int-to-string number))) () + (should (equal (comp-cstr-test-ts ',type-spec) + ',expected-type-spec)))) + + (defconst comp-cstr-typespec-tests-alist + `(;; 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 + ;; 5 + ((or integer number) . number) + ;; 6 + ((or (or integer symbol) number) . (or number symbol)) + ;; 7 + ((or (or integer symbol) (or number list)) . (or list number symbol)) + ;; 8 + ((or (or integer number) nil) . number) + ;; 9 + ((member foo) . (member foo)) + ;; 10 + ((member foo bar) . (member bar foo)) + ;; 11 + ((or (member foo) (member bar)) . (member bar foo)) + ;; 12 + ((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO)) + ;; 13 + ((or (member foo) number) . (or (member foo) number)) + ;; 14 + ((or (integer 1 3) number) . number) + ;; 15 + (integer . integer) + ;; 16 + ((integer 1 2) . (integer 1 2)) + ;; 17 + ((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4))) + ;; 18 + ((or (integer -1 2) (integer 3 4)) . (integer -1 4)) + ;; 19 + ((or (integer -1 3) (integer 3 4)) . (integer -1 4)) + ;; 20 + ((or (integer -1 4) (integer 3 4)) . (integer -1 4)) + ;; 21 + ((or (integer -1 5) (integer 3 4)) . (integer -1 5)) + ;; 22 + ((or (integer -1 *) (integer 3 4)) . (integer -1 *)) + ;; 23 + ((or (integer -1 2) (integer * 4)) . (integer * 4)) + ;; 24 + ((and string array) . string) + ;; 25 + ((and cons atom) . nil) + ;; 26 + ((and (member foo) (member foo bar baz)) . (member foo)) + ;; 27 + ((and (member foo) (member bar)) . nil) + ;; 28 + ((and (member foo) symbol) . (member foo)) + ;; 29 + ((and (member foo) string) . nil) + ;; 30 + ((and (member foo) (integer 1 2)) . nil) + ;; 31 + ((and (member 1 2) (member 3 2)) . (integer 2 2)) + ;; 32 + ((and number (integer 1 2)) . (integer 1 2)) + ;; 33 + ((and integer (integer 1 2)) . (integer 1 2)) + ;; 34 + ((and (integer -1 0) (integer 3 5)) . nil) + ;; 35 + ((and (integer -1 2) (integer 3 5)) . nil) + ;; 36 + ((and (integer -1 3) (integer 3 5)) . (integer 3 3)) + ;; 37 + ((and (integer -1 4) (integer 3 5)) . (integer 3 4)) + ;; 38 + ((and (integer -1 5) nil) . nil) + ;; 39 + ((not symbol) . (not symbol)) + ;; 40 + ((or (member foo) (not (member foo bar))) . (not (member bar))) + ;; 41 + ((or (member foo bar) (not (member foo))) . t) + ;; 42 + ((or symbol (not sequence)) . (not sequence)) + ;; 43 + ((or symbol (not symbol)) . t) + ;; 44 + ((or symbol (not sequence)) . (not sequence)) + ;; 45 Conservative. + ((or vector (not sequence)) . t) + ;; 46 + ((or (integer 1 10) (not (integer * 5))) . (not (integer * 0))) + ;; 47 + ((or symbol (integer 1 10) (not (integer * 5))) . (not (integer * 0))) + ;; 48 + ((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0)))) + ;; 49 + ((or symbol (not (member foo))) . (not (member foo))) + ;; 50 + ((or (not symbol) (not (member foo))) . (not symbol)) + ;; 51 Conservative. + ((or (not (member foo)) string) . (not (member foo))) + ;; 52 Conservative. + ((or (member foo) (not string)) . (not string)) + ;; 53 + ((or (not (integer 1 2)) integer) . t) + ;; 54 + ((or (not (integer 1 2)) (not integer)) . (not integer)) + ;; 55 + ((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3 *)))) + ;; 56 + ((or number (not (integer 1 2))) . t) + ;; 57 + ((or atom (not (integer 1 2))) . t) + ;; 58 + ((or atom (not (member foo))) . t) + ;; 59 + ((and symbol (not cons)) . symbol) + ;; 60 + ((and symbol (not symbol)) . nil) + ;; 61 + ((and atom (not symbol)) . atom) + ;; 62 + ((and atom (not string)) . (or array sequence atom)) + ;; 63 Conservative + ((and symbol (not (member foo))) . symbol) + ;; 64 Conservative + ((and symbol (not (member 3))) . symbol) + ;; 65 + ((and (not (member foo)) (integer 1 10)) . (integer 1 10)) + ;; 66 + ((and (member foo) (not (integer 1 10))) . (member foo)) + ;; 67 + ((and t (not (member foo))) . (not (member foo))) + ;; 68 + ((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *))) + ;; 69 + ((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20))) + ;; 70 + ((and (not (member a)) (not (member b))) . (not (member a b))) + ;; 71 + ((and (not boolean) (not (member b))) . (not (or (member b) boolean))) + ;; 72 + ((and t (integer 1 1)) . (integer 1 1)) + ;; 73 + ((not (integer -1 5)) . (not (integer -1 5))) + ;; 74 + ((and boolean (or number marker)) . nil) + ;; 75 + ((and atom (or number marker)) . (or marker number)) + ;; 76 + ((and symbol (or number marker)) . nil) + ;; 77 + ((and (or symbol string) (or number marker)) . nil) + ;; 78 + ((and t t) . t) + ;; 79 + ((and (or marker number) (integer 0 0)) . (integer 0 0)) + ;; 80 + ((and t (not t)) . nil) + ;; 81 + ((or (integer 1 1) (not (integer 1 1))) . t) + ;; 82 + ((not t) . nil) + ;; 83 + ((not nil) . t) + ;; 84 + ((or (not string) t) . t) + ;; 85 + ((or (not vector) sequence) . sequence) + ;; 86 + ((or (not symbol) null) . t) + ;; 87 + ((and (or null integer) (not (or null integer))) . nil) + ;; 88 + ((and (or (member a b c)) (not (or (member a b)))) . (member c))) + "Alist type specifier -> expected type specifier.")) + +(defmacro comp-cstr-synthesize-tests () + "Generate all tests from `comp-cstr-typespec-tests-alist'." + `(progn + ,@(cl-loop + for i from 1 + for (ts . exp-ts) in comp-cstr-typespec-tests-alist + append (list (comp-cstr-typespec-test i ts exp-ts))))) + +(comp-cstr-synthesize-tests) + +;;; comp-cstr-tests.el ends here diff --git a/test/lisp/emacs-lisp/copyright-tests.el b/test/lisp/emacs-lisp/copyright-tests.el index 7deb8b53a2e..6bb6e350d17 100644 --- a/test/lisp/emacs-lisp/copyright-tests.el +++ b/test/lisp/emacs-lisp/copyright-tests.el @@ -37,8 +37,12 @@ . ";; Copyright (C) 2017, 2019 Free Software Foundation, Inc.") (";; Copyright (C) 2017-2018 Free Software Foundation, Inc." . ";; Copyright (C) 2017-2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2017–2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2017–2019 Free Software Foundation, Inc.") (";; Copyright (C) 2005-2006, 2015, 2017-2018 Free Software Foundation, Inc." . ";; Copyright (C) 2005-2006, 2015, 2017-2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2005–2006, 2015, 2017–2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2005–2006, 2015, 2017–2019 Free Software Foundation, Inc.") (";; copyright '18 FSF" . ";; copyright '18, '19 FSF"))) diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index a3010f9e354..9257f167d67 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -62,12 +62,12 @@ (defun edebug-test-code-format-vector-node (node) !start!(concat "[" - (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply! + (apply #'concat (mapcar #'edebug-test-code-format-node node))!apply! "]")) (defun edebug-test-code-format-list-node (node) !start!(concat "{" - (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply! + (apply #'concat (mapcar #'edebug-test-code-format-node node))!apply! "}")) (defun edebug-test-code-format-node (node) @@ -137,5 +137,21 @@ ,(cons func args)))) (wrap + 1 x))) +(defun edebug-test-code-cl-flet1 () + (cl-flet + ;; This `&rest' sexp head should not collide with + ;; the Edebug spec elem of the same name. + ((f (&rest x) x) + (gate (x) (+ x 5))) + ;; This call to `gate' shouldn't collide with the Edebug spec elem + ;; of the same name. + (message "Hi %s" (gate 7)))) + +(defun edebug-test-code-use-gv-expander (x) + (declare (gv-expander + (lambda (do) + (funcall do `(car ,x) (lambda (v) `(setcar ,x ,v)))))) + (car x)) + (provide 'edebug-test-code) ;;; edebug-test-code.el ends here diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index d60a6cb3d50..2f45050e2eb 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -219,16 +219,16 @@ index." (with-current-buffer (find-file-noselect edebug-tests-temp-file) (setq saved-local-map overriding-local-map) (setq overriding-local-map edebug-tests-keymap) - (add-hook 'post-command-hook 'edebug-tests-post-command)) + (add-hook 'post-command-hook #'edebug-tests-post-command)) (advice-add 'exit-recursive-edit - :around 'edebug-tests-preserve-keyboard-macro-state) + :around #'edebug-tests-preserve-keyboard-macro-state) (unwind-protect (kmacro-call-macro nil nil nil kbdmac) (advice-remove 'exit-recursive-edit - 'edebug-tests-preserve-keyboard-macro-state) + #'edebug-tests-preserve-keyboard-macro-state) (with-current-buffer (find-file-noselect edebug-tests-temp-file) (setq overriding-local-map saved-local-map) - (remove-hook 'post-command-hook 'edebug-tests-post-command))))) + (remove-hook 'post-command-hook #'edebug-tests-post-command))))) (defun edebug-tests-preserve-keyboard-macro-state (orig &rest args) "Call ORIG with ARGS preserving the value of `executing-kbd-macro'. @@ -857,12 +857,14 @@ test and possibly others should be updated." (ert-deftest edebug-tests-trivial-backquote () "Edebug can instrument a trivial backquote expression (Bug#23651)." (edebug-tests-with-normal-env - (read-only-mode -1) - (delete-region (point-min) (point-max)) - (insert "`1") - (read-only-mode) + (let ((inhibit-read-only t)) + (delete-region (point-min) (point-max)) + (insert "`1")) (edebug-eval-defun nil) - (should (string-match-p (regexp-quote "1 (#o1, #x1, ?\\C-a)") + ;; `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'). + (should (string-match-p (regexp-quote " (#o1, #x1, ?\\C-a)") edebug-tests-messages)) (setq edebug-tests-messages "") @@ -912,13 +914,17 @@ test and possibly others should be updated." (ert-deftest edebug-tests-cl-macrolet () "Edebug can instrument `cl-macrolet' expressions. (Bug#29919)" (edebug-tests-with-normal-env - (edebug-tests-setup-@ "use-cl-macrolet" '(10) t) + (edebug-tests-locate-def "use-cl-macrolet") (edebug-tests-run-kbd-macro - "@ SPC SPC" + "C-u C-M-x SPC" (edebug-tests-should-be-at "use-cl-macrolet" "func") - (edebug-tests-should-match-result-in-messages "+") - "g" - (should (equal edebug-tests-@-result "The result of applying + to (1 x) is 11"))))) + (edebug-tests-should-match-result-in-messages "+")) + (let ((edebug-initial-mode 'Go-nonstop)) + (edebug-tests-setup-@ "use-cl-macrolet" '(10) t)) + (edebug-tests-run-kbd-macro + "@ SPC g" + (should (equal edebug-tests-@-result "The result of applying + to (1 x) is 11")) + ))) (ert-deftest edebug-tests-backtrace-goto-source () "Edebug can jump to instrumented source from its *Edebug-Backtrace* buffer." @@ -951,8 +957,41 @@ primary ones (Bug#42671)." (should (equal defined-symbols - (list (intern "edebug-cl-defmethod-qualifier :around ((_ number))") - (intern "edebug-cl-defmethod-qualifier ((_ number))"))))))) + (list (intern "edebug-cl-defmethod-qualifier :around (number)") + (intern "edebug-cl-defmethod-qualifier (number)"))))))) + +(ert-deftest edebug-tests--conflicting-internal-names () + "Check conflicts between form's head symbols and Edebug spec elements." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "cl-flet1" '(10) t))) + +(ert-deftest edebug-tests-gv-expander () + "Edebug can instrument `gv-expander' expressions." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "use-gv-expander" nil t) + (should (equal + (catch 'text + (run-at-time 0 nil + (lambda () (throw 'text (buffer-substring (point) (+ (point) 5))))) + (eval '(setf (edebug-test-code-use-gv-expander (cons 'a 'b)) 3) t)) + "(func")))) + +(defun edebug-tests--read (form spec) + (with-temp-buffer + (print form (current-buffer)) + (goto-char (point-min)) + (cl-letf ((edebug-all-forms t) + ((get (car form) 'edebug-form-spec) spec)) + (edebug--read nil (current-buffer))))) + +(ert-deftest edebug-tests--&rest-behavior () + ;; `&rest' is documented to allow the last "repetition" to be aborted early. + (should (edebug-tests--read '(dummy x 1 y 2 z) + '(&rest symbolp integerp))) + ;; `&rest' should notice here that the "symbolp integerp" sequence + ;; is not respected. + (should-error (edebug-tests--read '(dummy x 1 2 y) + '(&rest symbolp integerp)))) (ert-deftest edebug-tests-cl-flet () "Check that Edebug can instrument `cl-flet' forms without name @@ -976,32 +1015,35 @@ clashes (Bug#41853)." ;; Make generated symbols reproducible. (gensym-counter 10000)) (eval-buffer) - (should (equal (reverse instrumented-names) + ;; Use `format' so as to throw away differences due to + ;; interned/uninterned symbols. + (should (equal (format "%s" (reverse instrumented-names)) ;; The outer definitions come after the inner ;; ones because their body ends later. - ;; FIXME: There are twice as many inner - ;; definitions as expected due to Bug#41988. - ;; Once that bug is fixed, remove the duplicates. ;; FIXME: We'd rather have names such as ;; `edebug-tests-cl-flet-1@inner@cl-flet@10000', ;; but that requires further changes to Edebug. - '(inner@cl-flet@10000 - inner@cl-flet@10001 - inner@cl-flet@10002 - inner@cl-flet@10003 - edebug-tests-cl-flet-1 - inner@cl-flet@10004 - inner@cl-flet@10005 - edebug-tests-cl-flet-2)))))) + (format "%s" '(inner@cl-flet@10000 + inner@cl-flet@10001 + edebug-tests-cl-flet-1 + inner@cl-flet@10002 + edebug-tests-cl-flet-2))))))) + +(defmacro edebug-tests--duplicate-symbol-backtrack (arg) + "Helper macro that exemplifies Bug#42701. +ARG is either (FORM) or (FORM IGNORED)." + (declare (debug ([&or (form) (form sexp)]))) + (car arg)) (ert-deftest edebug-tests-duplicate-symbol-backtrack () "Check that Edebug doesn't create duplicate symbols when backtracking (Bug#42701)." (with-temp-buffer - (dolist (form '((require 'subr-x) - (defun edebug-tests-duplicate-symbol-backtrack () - (if-let (x (funcall (lambda (y) 1) 2)) 3 4)))) - (print form (current-buffer))) + (print '(defun edebug-tests-duplicate-symbol-backtrack () + (edebug-tests--duplicate-symbol-backtrack + ;; Passing (FORM IGNORED) forces backtracking. + ((lambda () 123) ignored))) + (current-buffer)) (let* ((edebug-all-defs t) (edebug-initial-mode 'Go-nonstop) (instrumented-names ()) @@ -1026,5 +1068,30 @@ backtracking (Bug#42701)." "edebug-anon10001" "edebug-tests-duplicate-symbol-backtrack")))))) +(defmacro edebug-tests--duplicate-&define (_arg) + "Helper macro for the ERT test `edebug-tests-duplicate-&define'. +The Edebug specification is similar to the one used by `cl-flet' +previously; see Bug#41988." + (declare (debug (&or (&define name function-form) (defun))))) + +(ert-deftest edebug-tests-duplicate-&define () + "Check that Edebug doesn't backtrack out of `&define' forms. +This avoids potential duplicate definitions (Bug#41988)." + (with-temp-buffer + (print '(defun edebug-tests-duplicate-&define () + (edebug-tests--duplicate-&define + (edebug-tests-duplicate-&define-inner () nil))) + (current-buffer)) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name)))) + (should-error (eval-buffer) :type 'invalid-read-syntax)))) + (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 285616a7806..9f9bb73133c 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -1,4 +1,4 @@ -;;; eieio-testsinvoke.el -- eieio tests for method invocation -*- lexical-binding:t -*- +;;; eieio-test-methodinvoke.el --- eieio tests for method invocation -*- lexical-binding:t -*- ;; Copyright (C) 2005, 2008, 2010, 2013-2021 Free Software Foundation, ;; Inc. diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index a47fb8053b9..3ec42343443 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -1,4 +1,4 @@ -;;; eieio-tests.el -- eieio test routines -*- lexical-binding: t -*- +;;; eieio-tests.el --- eieio test routines -*- lexical-binding: t -*- ;; Copyright (C) 1999-2003, 2005-2010, 2012-2021 Free Software ;; Foundation, Inc. @@ -574,7 +574,21 @@ METHOD is the method that was attempting to be called." (setf (get-slot-3 eitest-t1) 'setf-emu) (should (eq (get-slot-3 eitest-t1) 'setf-emu)) ;; Roll back - (setf (get-slot-3 eitest-t1) 'emu)) + (setf (get-slot-3 eitest-t1) 'emu) + (defvar eieio-tests-initform-was-evaluated) + (defclass eieio-tests-initform-not-evaluated-when-initarg-is-present () + ((slot-with-initarg-and-initform + :initarg :slot-with-initarg-and-initform + :initform (setf eieio-tests-initform-was-evaluated t)))) + (setq eieio-tests-initform-was-evaluated nil) + (make-instance + 'eieio-tests-initform-not-evaluated-when-initarg-is-present) + (should eieio-tests-initform-was-evaluated) + (setq eieio-tests-initform-was-evaluated nil) + (make-instance + 'eieio-tests-initform-not-evaluated-when-initarg-is-present + :slot-with-initarg-and-initform t) + (should-not eieio-tests-initform-was-evaluated)) (defvar eitest-t2 nil) (ert-deftest eieio-test-26-default-inheritance () diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 40cb432708e..5c9696105e9 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -814,7 +814,7 @@ This macro is used to test if macroexpansion in `should' works." :body (lambda () (should (integerp (ert-fail "Boo")))))))) (should (ert-test-failed-p result)) (should (equal (ert-test-failed-condition result) - '(ert-test-failed ("Boo")))))) + '(ert-test-failed "Boo"))))) (provide 'ert-tests) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index f46fa63e4ce..9f40a18d343 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -7,18 +7,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index ffcd16ad094..a1b9f64fdb1 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -45,6 +45,7 @@ BODY twice: once using ordinary `eval' and once using lambda-generators. The test ensures that the two forms produce identical output." + (declare (indent 1)) `(progn (ert-deftest ,name () (should @@ -62,8 +63,6 @@ identical output." (let ((cps-inhibit-atomic-optimization t)) (iter-lambda () (iter-yield (progn ,@body))))))))))) -(put 'cps-testcase 'lisp-indent-function 1) - (defvar *cps-test-i* nil) (defun cps-get-test-i () *cps-test-i*) diff --git a/test/lisp/emacs-lisp/lisp-mnt-tests.el b/test/lisp/emacs-lisp/lisp-mnt-tests.el new file mode 100644 index 00000000000..84cdc7205f2 --- /dev/null +++ b/test/lisp/emacs-lisp/lisp-mnt-tests.el @@ -0,0 +1,36 @@ +;;; lisp-mnt-tests.el --- Tests for lisp-mnt -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 2020-2021 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'lisp-mnt) + +(ert-deftest lm--tests-crack-address () + (should (equal (lm-crack-address + "Bob Weiner <rsw@gnu.org>, Mats Lidell <matsl@gnu.org>") + '(("Bob Weiner" . "rsw@gnu.org") + ("Mats Lidell" . "matsl@gnu.org"))))) + +(provide 'lisp-mnt-tests) +;;; lisp-mnt-tests.el ends here diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el index 85db3a00c8e..e2cecdf6b01 100644 --- a/test/lisp/emacs-lisp/lisp-mode-tests.el +++ b/test/lisp/emacs-lisp/lisp-mode-tests.el @@ -2,6 +2,8 @@ ;; Copyright (C) 2017-2021 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 diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index fd07011137a..78ecf3ff03d 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -8,6 +8,8 @@ ;; Author: Marcin Borkowski <mbork@mbork.pl> ;; Keywords: internal +;; 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 diff --git a/test/lisp/emacs-lisp/macroexp-resources/m1.el b/test/lisp/emacs-lisp/macroexp-resources/m1.el new file mode 100644 index 00000000000..96b5f7091af --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/m1.el @@ -0,0 +1,36 @@ +;;; m1.el --- Some sample code for macroexp-tests -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(defconst macroexp--m1-tests-filename (macroexp-file-name)) + +(eval-when-compile + (defconst macroexp--m1-tests-comp-filename (macroexp-file-name))) + +(defun macroexp--m1-tests-file-name () + (macroexp--test-get-file-name)) + +(provide 'm1) +;;; m1.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-resources/m2.el b/test/lisp/emacs-lisp/macroexp-resources/m2.el new file mode 100644 index 00000000000..4f2b96d8ca0 --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/m2.el @@ -0,0 +1,33 @@ +;;; m2.el --- More sample code for macroexp-tests -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(defconst macroexp--m2-tests-filename (macroexp-file-name)) + +(byte-compile-file (expand-file-name + "m1.el" (file-name-directory macroexp--m2-tests-filename))) + +(provide 'm2) +;;; m2.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el new file mode 100644 index 00000000000..89d3882d1da --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -0,0 +1,72 @@ +;;; macroexp-tests.el --- Tests for macroexp.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(ert-deftest macroexp--tests-fgrep () + (should (equal (macroexp--fgrep '((x) (y)) '([x] z ((u)))) + '((x)))) + (should (equal (macroexp--fgrep '((x) (y)) '#2=([y] ((y #2#)))) + '((y)))) + (should (equal (macroexp--fgrep '((x) (y)) '#2=([r] ((a x)) a b c d . #2#)) + '((x))))) + +(defconst macroexp--tests-filename (macroexp-file-name)) + +(defmacro macroexp--test-get-file-name () (macroexp-file-name)) + +(ert-deftest macroexp--tests-file-name () + (should (string-match + "\\`macroexp-tests.elc?\\'" + (file-name-nondirectory macroexp--tests-filename))) + (let ((rsrc-dir (expand-file-name + "macroexp-resources" + (file-name-directory macroexp--tests-filename)))) + (with-current-buffer + (find-file-noselect (expand-file-name "m1.el" rsrc-dir)) + (defvar macroexp--m1-tests-filename) + (declare-function macroexp--m1-tests-file-name "m1" ()) + ;; `macroexp-file-name' should work with `eval-buffer'. + (eval-buffer) + (should (equal "m1.el" + (file-name-nondirectory macroexp--m1-tests-filename))) + (should (equal "m1.el" + (file-name-nondirectory (macroexp--m1-tests-file-name)))) + (search-forward "macroexp--m1-tests-filename") + (makunbound 'macroexp--m1-tests-filename) + ;; `macroexp-file-name' should also work with `eval-defun'. + (eval-defun nil) + (should (equal "m1.el" + (file-name-nondirectory macroexp--m1-tests-filename)))) + + ;; Test the case where we load a file which byte-compiles another. + (defvar macroexp--m1-tests-comp-filename) + (makunbound 'macroexp--m1-tests-comp-filename) + (load (expand-file-name "m2.el" rsrc-dir)) + (should (equal "m1.el" + (file-name-nondirectory macroexp--m1-tests-comp-filename))))) + + +(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 9a2cd42a211..658ed2e7119 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -22,7 +22,7 @@ ;;; Commentary: -;; Tests for map.el +;; Tests for map.el. ;;; Code: @@ -30,12 +30,10 @@ (require 'map) (defmacro with-maps-do (var &rest body) - "Successively bind VAR to an alist, vector and hash-table. + "Successively bind VAR to an alist, plist, vector, and hash-table. Each map is built from the following alist data: -'((0 . 3) (1 . 4) (2 . 5)). -Evaluate BODY for each created map. - -\(fn (var map) body)" + \\='((0 . 3) (1 . 4) (2 . 5)). +Evaluate BODY for each created map." (declare (indent 1) (debug (symbolp body))) (let ((alist (make-symbol "alist")) (plist (make-symbol "plist")) @@ -53,43 +51,62 @@ Evaluate BODY for each created map. (dolist (,var (list ,alist ,plist ,vec ,ht)) ,@body)))) +(defmacro with-empty-maps-do (var &rest body) + "Like `with-maps-do', but with empty maps." + (declare (indent 1) (debug (symbolp body))) + `(dolist (,var (list (list) (vector) (make-hash-table))) + ,@body)) + +(ert-deftest test-map-plist-p () + "Test `map--plist-p'." + (with-empty-maps-do map + (should-not (map--plist-p map))) + (should-not (map--plist-p "")) + (should-not (map--plist-p '((())))) + (should (map--plist-p '(:a))) + (should (map--plist-p '(a))) + (should (map--plist-p '(nil))) + (should (map--plist-p '("")))) + (ert-deftest test-map-elt () (with-maps-do map (should (= 3 (map-elt map 0))) (should (= 4 (map-elt map 1))) (should (= 5 (map-elt map 2))) - (should (null (map-elt map -1))) - (should (null (map-elt map 4))))) + (should-not (map-elt map -1)) + (should-not (map-elt map 4)) + (should-not (map-elt map 0.1)))) (ert-deftest test-map-elt-default () (with-maps-do map - (should (= 5 (map-elt map 7 5))))) + (should (= 5 (map-elt map 7 5))) + (should (= 5 (map-elt map 0.1 5)))) + (with-empty-maps-do map + (should (= 5 (map-elt map 0 5))))) (ert-deftest test-map-elt-testfn () (let ((map (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) (should-not (map-elt map noneq-key)) - (should (map-elt map noneq-key nil 'equal)))) + (should (map-elt map noneq-key nil #'equal)))) (ert-deftest test-map-elt-with-nil-value () - (should (null (map-elt '((a . 1) - (b)) - 'b - '2)))) + (should-not (map-elt '((a . 1) (b)) 'b 2))) (ert-deftest test-map-put! () (with-maps-do map (setf (map-elt map 2) 'hello) (should (eq (map-elt map 2) 'hello))) (with-maps-do map - (map-put map 2 'hello) + (with-suppressed-warnings ((obsolete map-put)) + (map-put map 2 'hello)) (should (eq (map-elt map 2) 'hello))) (with-maps-do map (map-put! map 2 'hello) (should (eq (map-elt map 2) 'hello)) (if (not (or (hash-table-p map) - (and (listp map) (not (listp (car map)))))) ;plist! + (map--plist-p map))) (should-error (map-put! map 5 'value) ;; For vectors, it could arguably signal ;; map-not-inplace as well, but it currently doesn't. @@ -97,49 +114,88 @@ Evaluate BODY for each created map. 'map-not-inplace 'error)) (map-put! map 5 'value) - (should (eq (map-elt map 5) 'value)))) - (let ((ht (make-hash-table))) - (setf (map-elt ht 2) 'a) - (should (eq (map-elt ht 2) - 'a))) - (let ((alist '((0 . a) (1 . b) (2 . c)))) - (setf (map-elt alist 2) 'a) - (should (eq (map-elt alist 2) - 'a))) - (let ((vec [3 4 5])) - (should-error (setf (map-elt vec 3) 6)))) + (should (eq (map-elt map 5) 'value))))) + +(ert-deftest test-map-put!-new-keys () + "Test `map-put!' with new keys." + (with-maps-do map + (let ((size (map-length map))) + (if (arrayp map) + (progn + (should-error (setf (map-elt map 'k) 'v)) + (should-error (setf (map-elt map size) 'v))) + (setf (map-elt map 'k) 'v) + (should (eq (map-elt map 'k) 'v)) + (setf (map-elt map size) 'v) + (should (eq (map-elt map size) 'v)))))) (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." - (let ((alist '((0 . a)))) - (map-put alist 2 'b) - (should (eq (map-elt alist 2) - 'b)))) + (let ((alist (list (cons 0 'a)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist 2 'b)) + (should (eq (map-elt alist 2) 'b)))) (ert-deftest test-map-put-testfn-alist () (let ((alist (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) - (map-put alist noneq-key 3 #'equal) - (should-not (cddr alist)) - (map-put alist noneq-key 9 #'eql) - (should (cddr alist)))) + (with-suppressed-warnings ((obsolete map-put)) + (map-put alist noneq-key 3 #'equal) + (should-not (cddr alist)) + (map-put alist noneq-key 9 #'eql) + (should (cddr alist))))) (ert-deftest test-map-put-return-value () (let ((ht (make-hash-table))) - (should (eq (map-put ht 'a 'hello) 'hello)))) + (with-suppressed-warnings ((obsolete map-put)) + (should (eq (map-put ht 'a 'hello) 'hello))))) + +(ert-deftest test-map-insert-empty () + "Test `map-insert' on empty maps." + (with-empty-maps-do map + (if (arrayp map) + (should-error (map-insert map 0 6)) + (let ((new (map-insert map 0 6))) + (should-not (eq map new)) + (should-not (map-pairs map)) + (should (= (map-elt new 0) 6)))))) + +(ert-deftest test-map-insert () + "Test `map-insert'." + (with-maps-do map + (let ((pairs (map-pairs map)) + (size (map-length map)) + (new (map-insert map 0 6))) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new 0) 6)) + (if (arrayp map) + (should-error (map-insert map size 7)) + (setq new (map-insert map size 7)) + (should-not (eq map new)) + (should (equal (map-pairs map) pairs)) + (should (= (map-elt new size) 7)))))) (ert-deftest test-map-delete () (with-maps-do map - (map-delete map 1) - (should (null (map-elt map 1)))) + (should (map-elt map 1)) + (should (eq map (map-delete map 1))) + (should-not (map-elt map 1))) + (with-maps-do map + (should-not (map-elt map -2)) + (should (eq map (map-delete map -2))) + (should-not (map-elt map -2))) (with-maps-do map - (map-delete map -2) - (should (null (map-elt map -2))))) + ;; Check for OBOE. + (let ((key (map-length map))) + (should-not (map-elt map key)) + (should (eq map (map-delete map key))) + (should-not (map-elt map key))))) -(ert-deftest test-map-delete-return-value () - (let ((ht (make-hash-table))) - (should (eq (map-delete ht 'a) ht)))) +(ert-deftest test-map-delete-empty () + (with-empty-maps-do map + (should (eq map (map-delete map t))))) (ert-deftest test-map-nested-elt () (let ((vec [a b [c d [e f]]])) @@ -149,8 +205,9 @@ Evaluate BODY for each created map. (d . 3) (e . ((f . 4) (g . 5)))))))) - (should (eq (map-nested-elt alist '(b e f)) - 4))) + (should (eq (map-nested-elt alist '(b e f)) 4))) + (let ((plist '(a 1 b (c 2 d 3 e (f 4 g 5))))) + (should (eq (map-nested-elt plist '(b e f)) 4))) (let ((ht (make-hash-table))) (setf (map-elt ht 'a) 1) (setf (map-elt ht 'b) (make-hash-table)) @@ -160,221 +217,266 @@ Evaluate BODY for each created map. (ert-deftest test-map-nested-elt-default () (let ((vec [a b [c d]])) - (should (null (map-nested-elt vec '(2 3)))) - (should (null (map-nested-elt vec '(2 1 1)))) + (should-not (map-nested-elt vec '(2 3))) + (should-not (map-nested-elt vec '(2 1 1))) (should (= 4 (map-nested-elt vec '(2 1 1) 4))))) (ert-deftest test-mapp () - (should (mapp nil)) - (should (mapp '((a . b) (c . d)))) - (should (mapp '(a b c d))) - (should (mapp [])) - (should (mapp [1 2 3])) - (should (mapp (make-hash-table))) + (with-empty-maps-do map + (should (mapp map))) + (with-maps-do map + (should (mapp map))) + (should (mapp "")) (should (mapp "hello")) - (should (not (mapp 1))) - (should (not (mapp 'hello)))) + (should-not (mapp 1)) + (should-not (mapp 'hello))) (ert-deftest test-map-keys () (with-maps-do map (should (equal (map-keys map) '(0 1 2)))) - (should (null (map-keys nil))) - (should (null (map-keys [])))) + (with-empty-maps-do map + (should-not (map-keys map)))) (ert-deftest test-map-values () (with-maps-do map - (should (equal (map-values map) '(3 4 5))))) + (should (equal (map-values map) '(3 4 5)))) + (with-empty-maps-do map + (should-not (map-values map)))) (ert-deftest test-map-pairs () (with-maps-do map - (should (equal (map-pairs map) '((0 . 3) - (1 . 4) - (2 . 5)))))) + (should (equal (map-pairs map) + '((0 . 3) + (1 . 4) + (2 . 5))))) + (with-empty-maps-do map + (should-not (map-pairs map)))) (ert-deftest test-map-length () - (let ((ht (make-hash-table))) - (puthash 'a 1 ht) - (puthash 'b 2 ht) - (puthash 'c 3 ht) - (puthash 'd 4 ht) - (should (= 0 (map-length nil))) - (should (= 0 (map-length []))) - (should (= 0 (map-length (make-hash-table)))) - (should (= 5 (map-length [0 1 2 3 4]))) - (should (= 2 (map-length '((a . 1) (b . 2))))) - (should (= 4 (map-length ht))))) + (with-empty-maps-do map + (should (zerop (map-length map)))) + (with-maps-do map + (should (= 3 (map-length map)))) + (should (= 1 (map-length '(nil 1)))) + (should (= 2 (map-length '(nil 1 t 2)))) + (should (= 2 (map-length '((a . 1) (b . 2))))) + (should (= 5 (map-length [0 1 2 3 4]))) + (should (= 4 (map-length #s(hash-table data (a 1 b 2 c 3 d 4)))))) (ert-deftest test-map-copy () (with-maps-do map (let ((copy (map-copy map))) - (should (equal (map-keys map) (map-keys copy))) - (should (equal (map-values map) (map-values copy))) - (should (not (eq map copy)))))) + (should (equal (map-pairs map) (map-pairs copy))) + (should-not (eq map copy)) + (map-put! map 0 0) + (should-not (equal (map-pairs map) (map-pairs copy))))) + (with-empty-maps-do map + (should-not (map-pairs (map-copy map))))) + +(ert-deftest test-map-copy-alist () + "Test use of `copy-alist' for alists." + (let* ((cons (list 'a 1 2)) + (alist (list cons)) + (copy (map-copy alist))) + (setcar cons 'b) + (should (equal alist '((b 1 2)))) + (should (equal copy '((a 1 2)))) + (setcar (cdr cons) 0) + (should (equal alist '((b 0 2)))) + (should (equal copy '((a 0 2)))) + (setcdr cons 3) + (should (equal alist '((b . 3)))) + (should (equal copy '((a 0 2)))))) (ert-deftest test-map-apply () - (with-maps-do map - (should (equal (map-apply (lambda (k v) (cons (int-to-string k) v)) - map) - '(("0" . 3) ("1" . 4) ("2" . 5))))) - (let ((vec [a b c])) - (should (equal (map-apply (lambda (k v) (cons (1+ k) v)) - vec) - '((1 . a) - (2 . b) - (3 . c)))))) + (let ((fn (lambda (k v) (cons (number-to-string k) v)))) + (with-maps-do map + (should (equal (map-apply fn map) + '(("0" . 3) ("1" . 4) ("2" . 5))))) + (with-empty-maps-do map + (should-not (map-apply fn map))))) (ert-deftest test-map-do () - (with-maps-do map - (let ((result nil)) - (map-do (lambda (k v) - (push (list (int-to-string k) v) result)) - map) - (should (equal result '(("2" 5) ("1" 4) ("0" 3))))))) + (let* (res + (fn (lambda (k v) + (push (list (number-to-string k) v) res)))) + (with-empty-maps-do map + (should-not (map-do fn map)) + (should-not res)) + (with-maps-do map + (setq res nil) + (should-not (map-do fn map)) + (should (equal res '(("2" 5) ("1" 4) ("0" 3))))))) (ert-deftest test-map-keys-apply () (with-maps-do map - (should (equal (map-keys-apply (lambda (k) (int-to-string k)) - map) - '("0" "1" "2")))) - (let ((vec [a b c])) - (should (equal (map-keys-apply (lambda (k) (1+ k)) - vec) - '(1 2 3))))) + (should (equal (map-keys-apply #'1+ map) '(1 2 3)))) + (with-empty-maps-do map + (let (ks) + (should-not (map-keys-apply (lambda (k) (push k ks)) map)) + (should-not ks)))) (ert-deftest test-map-values-apply () (with-maps-do map - (should (equal (map-values-apply (lambda (v) (1+ v)) - map) - '(4 5 6)))) - (let ((vec [a b c])) - (should (equal (map-values-apply (lambda (v) (symbol-name v)) - vec) - '("a" "b" "c"))))) + (should (equal (map-values-apply #'1+ map) '(4 5 6)))) + (with-empty-maps-do map + (let (vs) + (should-not (map-values-apply (lambda (v) (push v vs)) map)) + (should-not vs)))) (ert-deftest test-map-filter () (with-maps-do map - (should (equal (map-keys (map-filter (lambda (_k v) - (<= 4 v)) - map)) - '(1 2))) - (should (null (map-filter (lambda (k _v) - (eq 'd k)) - map)))) - (should (null (map-filter (lambda (_k v) - (eq 3 v)) - [1 2 4 5]))) - (should (equal (map-filter (lambda (k _v) - (eq 3 k)) - [1 2 4 5]) - '((3 . 5))))) + (should (equal (map-filter (lambda (_k v) (> v 3)) map) + '((1 . 4) (2 . 5)))) + (should (equal (map-filter #'always map) (map-pairs map))) + (should-not (map-filter #'ignore map))) + (with-empty-maps-do map + (should-not (map-filter #'always map)) + (should-not (map-filter #'ignore map)))) (ert-deftest test-map-remove () (with-maps-do map - (should (equal (map-keys (map-remove (lambda (_k v) - (>= v 4)) - map)) - '(0))) - (should (equal (map-keys (map-remove (lambda (k _v) - (eq 'd k)) - map)) - (map-keys map)))) - (should (equal (map-remove (lambda (_k v) - (eq 3 v)) - [1 2 4 5]) - '((0 . 1) - (1 . 2) - (2 . 4) - (3 . 5)))) - (should (null (map-remove (lambda (k _v) - (>= k 0)) - [1 2 4 5])))) + (should (equal (map-remove (lambda (_k v) (> v 3)) map) + '((0 . 3)))) + (should (equal (map-remove #'ignore map) (map-pairs map))) + (should-not (map-remove #'always map))) + (with-empty-maps-do map + (should-not (map-remove #'always map)) + (should-not (map-remove #'ignore map)))) (ert-deftest test-map-empty-p () - (should (map-empty-p nil)) - (should (not (map-empty-p '((a . b) (c . d))))) - (should (map-empty-p [])) - (should (not (map-empty-p [1 2 3]))) - (should (map-empty-p (make-hash-table))) - (should (not (map-empty-p "hello"))) - (should (map-empty-p ""))) + (with-empty-maps-do map + (should (map-empty-p map))) + (should (map-empty-p "")) + (should-not (map-empty-p '((a . b) (c . d)))) + (should-not (map-empty-p [1 2 3])) + (should-not (map-empty-p "hello"))) (ert-deftest test-map-contains-key () - (should (map-contains-key '((a . 1) (b . 2)) 'a)) - (should (not (map-contains-key '((a . 1) (b . 2)) 'c))) - (should (map-contains-key '(("a" . 1)) "a")) - (should (not (map-contains-key '(("a" . 1)) "a" #'eq))) - (should (map-contains-key [a b c] 2)) - (should (not (map-contains-key [a b c] 3)))) + (with-empty-maps-do map + (should-not (map-contains-key map -1)) + (should-not (map-contains-key map 0)) + (should-not (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map)))) + (with-maps-do map + (should-not (map-contains-key map -1)) + (should (map-contains-key map 0)) + (should (map-contains-key map 1)) + (should-not (map-contains-key map (map-length map))))) + +(ert-deftest test-map-contains-key-testfn () + "Test `map-contains-key' under different equalities." + (let ((key (string ?a)) + (plist '("a" 1 a 2)) + (alist '(("a" . 1) (a . 2)))) + (should (map-contains-key alist 'a)) + (should (map-contains-key plist 'a)) + (should (map-contains-key alist 'a #'eq)) + (should (map-contains-key plist 'a #'eq)) + (should (map-contains-key alist key)) + (should-not (map-contains-key plist key)) + (should-not (map-contains-key alist key #'eq)) + (should-not (map-contains-key plist key #'eq)))) (ert-deftest test-map-some () (with-maps-do map - (should (map-some (lambda (k _v) - (eq 1 k)) - map)) - (should-not (map-some (lambda (k _v) - (eq 'd k)) - map))) - (let ((vec [a b c])) - (should (map-some (lambda (k _v) - (> k 1)) - vec)) - (should-not (map-some (lambda (k _v) - (> k 3)) - vec)))) + (should (eq (map-some (lambda (k _v) (and (= k 1) 'found)) map) + 'found)) + (should-not (map-some #'ignore map))) + (with-empty-maps-do map + (should-not (map-some #'always map)) + (should-not (map-some #'ignore map)))) (ert-deftest test-map-every-p () (with-maps-do map - (should (map-every-p (lambda (k _v) - k) - map)) - (should (not (map-every-p (lambda (_k _v) - nil) - map)))) - (let ((vec [a b c])) - (should (map-every-p (lambda (k _v) - (>= k 0)) - vec)) - (should (not (map-every-p (lambda (k _v) - (> k 3)) - vec))))) + (should (map-every-p #'always map)) + (should-not (map-every-p #'ignore map)) + (should-not (map-every-p (lambda (k _v) (zerop k)) map))) + (with-empty-maps-do map + (should (map-every-p #'always map)) + (should (map-every-p #'ignore map)) + (should (map-every-p (lambda (k _v) (zerop k)) map)))) (ert-deftest test-map-into () - (let* ((alist '((a . 1) (b . 2))) + (let* ((plist '(a 1 b 2)) + (alist '((a . 1) (b . 2))) (ht (map-into alist 'hash-table)) (ht2 (map-into alist '(hash-table :test equal)))) (should (hash-table-p ht)) - (should (equal (map-into (map-into alist 'hash-table) 'list) - alist)) - (should (listp (map-into ht 'list))) - (should (equal (map-keys (map-into (map-into ht 'list) 'hash-table)) - (map-keys ht))) - (should (equal (map-values (map-into (map-into ht 'list) 'hash-table)) - (map-values ht))) + (should (equal (map-into ht 'list) alist)) + (should (equal (map-pairs (map-into (map-into ht 'list) 'hash-table)) + (map-pairs ht))) (should (equal (map-into ht 'alist) (map-into ht2 'alist))) - (should (eq (hash-table-test ht2) 'equal)) - (should (null (map-into nil 'list))) - (should (map-empty-p (map-into nil 'hash-table))) - (should-error (map-into [1 2 3] 'string)))) + (should (equal (map-into alist 'list) alist)) + (should (equal (map-into alist 'alist) alist)) + (should (equal (map-into alist 'plist) plist)) + (should (equal (map-into plist 'alist) alist)) + (should (equal (map-into plist 'plist) plist))) + (should-error (map-into [1 2 3] 'string) :type 'cl-no-applicable-method)) + +(ert-deftest test-map-into-hash-test () + "Test `map-into' with different hash-table test functions." + (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)) + (should (eq (hash-table-test (map-into () '(hash-table :test eql))) #'eql)) + (should (eq (hash-table-test (map-into () '(hash-table :test equal))) + #'equal))) + +(ert-deftest test-map-into-empty () + "Test `map-into' with empty maps." + (with-empty-maps-do map + (should-not (map-into map 'list)) + (should-not (map-into map 'alist)) + (should-not (map-into map 'plist)) + (should (map-empty-p (map-into map 'hash-table))))) (ert-deftest test-map-let () (map-let (foo bar baz) '((foo . 1) (bar . 2)) (should (= foo 1)) (should (= bar 2)) - (should (null baz))) + (should-not baz)) (map-let (('foo a) ('bar b) ('baz c)) '((foo . 1) (bar . 2)) (should (= a 1)) (should (= b 2)) - (should (null c)))) + (should-not c))) + +(ert-deftest test-map-merge () + "Test `map-merge'." + (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)))) + '((a . 1) (b . 2) (c . 4)))) + (should (equal (map-merge 'list () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge 'alist () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge 'plist () '(:a 1)) '(:a 1)))) (ert-deftest test-map-merge-with () - (should (equal (map-merge-with 'list #'+ - '((1 . 2)) - '((1 . 3) (2 . 4)) - '((1 . 1) (2 . 5) (3 . 0))) - '((3 . 0) (2 . 9) (1 . 6))))) + (should (equal (sort (map-merge-with 'list #'+ + '((1 . 2)) + '((1 . 3) (2 . 4)) + '((1 . 1) (2 . 5) (3 . 0))) + #'car-less-than-car) + '((1 . 6) (2 . 9) (3 . 0)))) + (should (equal (map-merge-with 'list #'+ () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge-with 'alist #'+ () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge-with 'plist #'+ () '(:a 1)) '(:a 1)))) + +(ert-deftest test-map-merge-empty () + "Test merging of empty maps." + (should-not (map-merge 'list)) + (should-not (map-merge 'alist)) + (should-not (map-merge 'plist)) + (should-not (map-merge-with 'list #'+)) + (should-not (map-merge-with 'alist #'+)) + (should-not (map-merge-with 'plist #'+)) + (should (map-empty-p (map-merge 'hash-table))) + (should (map-empty-p (map-merge-with 'hash-table #'+))) + (should-error (map-merge 'array) :type 'cl-no-applicable-method) + (should-error (map-merge-with 'array #'+) :type 'cl-no-applicable-method)) (ert-deftest test-map-plist-pcase () (let ((plist '(:one 1 :two 2))) @@ -382,5 +484,42 @@ Evaluate BODY for each created map. (list one two)) '(1 2))))) +(ert-deftest test-map-setf-alist-insert-key () + (let ((alist)) + (should (equal (setf (map-elt alist 'key) 'value) + 'value)) + (should (equal alist '((key . value)))))) + +(ert-deftest test-map-setf-alist-overwrite-key () + (let ((alist '((key . value1)))) + (should (equal (setf (map-elt alist 'key) 'value2) + 'value2)) + (should (equal alist '((key . value2)))))) + +(ert-deftest test-map-setf-plist-insert-key () + (let ((plist '(key value))) + (should (equal (setf (map-elt plist 'key2) 'value2) + 'value2)) + (should (equal plist '(key value key2 value2))))) + +(ert-deftest test-map-setf-plist-overwrite-key () + (let ((plist '(key value))) + (should (equal (setf (map-elt plist 'key) 'value2) + 'value2)) + (should (equal plist '(key value2))))) + +(ert-deftest test-hash-table-setf-insert-key () + (let ((ht (make-hash-table))) + (should (equal (setf (map-elt ht 'key) 'value) + 'value)) + (should (equal (map-elt ht 'key) 'value)))) + +(ert-deftest test-hash-table-setf-overwrite-key () + (let ((ht (make-hash-table))) + (puthash 'key 'value1 ht) + (should (equal (setf (map-elt ht 'key) 'value2) + 'value2)) + (should (equal (map-elt ht 'key) 'value2)))) + (provide 'map-tests) ;;; map-tests.el ends here diff --git a/test/lisp/emacs-lisp/memory-report-tests.el b/test/lisp/emacs-lisp/memory-report-tests.el index da5f4f5700f..0c0297b5fce 100644 --- a/test/lisp/emacs-lisp/memory-report-tests.el +++ b/test/lisp/emacs-lisp/memory-report-tests.el @@ -45,6 +45,7 @@ (should (equal (memory-report-object-size (list 'foo)) 16)) + (should (equal (memory-report-object-size (vector 1 2 3)) 64)) (should (equal (memory-report-object-size (vector 1 2 3 4)) 80)) (should (equal (memory-report-object-size "") 32)) @@ -52,6 +53,21 @@ (should (equal (memory-report-object-size (propertize "a" 'face 'foo)) 81))) +(ert-deftest memory-report-sizes-vectors () + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + ["long string that should be at least 40 bytes"]) + 108)) + (let ((string "long string that should be at least 40 bytes")) + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + (vector string)) + 108)) + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + (vector string string)) + 124)))) + (provide 'memory-report-tests) ;;; memory-report-tests.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 67d647d3b9e..29435799555 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -263,6 +263,74 @@ Must called from within a `tar-mode' buffer." (should (file-exists-p autoloads-file)) (should-not (get-file-buffer autoloads-file))))) +(ert-deftest package-test-install-file () + "Install files with `package-install-file'." + (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)))) + (should-not (package-installed-p 'simple-single)) + (package-install-file source-file) + (should (package-installed-p 'simple-single)) + (package-delete (cadr (assq 'simple-single package-alist))) + (should-not (package-installed-p 'simple-single))) + + (let* ((pkg-el "multi-file-0.2.3.tar") + (source-file (expand-file-name pkg-el (ert-resource-directory)))) + (package-initialize) + (should-not (package-installed-p 'multie-file)) + (package-install-file source-file) + (should (package-installed-p 'multi-file)) + (package-delete (cadr (assq 'multi-file package-alist)))) + )) + +(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)." + (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)))) + + (with-temp-buffer + (insert-file-contents source-file) + + (let (hashes) + (dolist (coding '(unix dos mac) hashes) + (let* ((eol-file (expand-file-name pkg-el package-test-user-dir))) + ;; save package with this EOL convention. + (set-buffer-file-coding-system coding) + (write-region (point-min) (point-max) eol-file) + + (should-not (package-installed-p 'simple-single)) + (package-install-file eol-file) + (should (package-installed-p 'simple-single)) + + ;; check the package file has been installed unmodified. + (let ((eol-hash (with-temp-buffer + (insert-file-contents-literally eol-file) + (buffer-hash)))) + ;; also perform an additional check that the package + ;; file created with this EOL convention is different + ;; than all the others created so far. + (should-not (member eol-hash hashes)) + (setq hashes (cons eol-hash hashes)) + + (let* ((descr (cadr (assq 'simple-single package-alist))) + (pkg-dir (package-desc-dir descr)) + (dest-file (expand-file-name "simple-single.el" pkg-dir )) + (dest-hash (with-temp-buffer + (insert-file-contents-literally dest-file) + (buffer-hash)))) + + (should (string= dest-hash eol-hash)))) + + (package-delete (cadr (assq 'simple-single package-alist))) + (should-not (package-installed-p 'simple-single)) + (delete-file eol-file) + (should-not (file-exists-p eol-file)) + ))))))) + (ert-deftest package-test-install-dependency () "Install a package which includes a dependency." (with-package-test () diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index e6f4c097504..7ad01e7aef7 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -75,8 +75,86 @@ (ert-deftest pcase-tests-vectors () (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))) -;; Local Variables: -;; no-byte-compile: t -;; End: +(ert-deftest pcase-tests-bug14773 () + (let ((f (lambda (x) + (pcase 'dummy + ((and (let var x) (guard var)) 'left) + ((and (let var (not x)) (guard var)) 'right))))) + (should (equal (funcall f t) 'left)) + (should (equal (funcall f nil) 'right)))) + +(ert-deftest pcase-tests-bug46786 () + (let ((self 'outer)) + (ignore self) + (should (equal (cl-macrolet ((show-self () `(list 'self self))) + (pcase-let ((`(,self ,_self2) '(inner "2"))) + (show-self))) + '(self inner))))) + +(ert-deftest pcase-tests-or-vars () + (let ((f (lambda (v) + (pcase v + ((or (and 'b1 (let x1 4) (let x2 5)) + (and 'b2 (let y1 8) (let y2 9))) + (list x1 x2 y1 y2)))))) + (should (equal (funcall f 'b1) '(4 5 nil nil))) + (should (equal (funcall f 'b2) '(nil nil 8 9))))) + +(ert-deftest pcase-tests-cl-type () + (should (equal (pcase 1 + ((cl-type integer) 'integer)) + 'integer)) + (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)))) + +(ert-deftest pcase-tests-setq () + (should (equal (let (a b) + (pcase-setq `((,a) (,b)) '((1) (2))) + (list a b)) + (list 1 2))) + + (should (equal (list nil nil) + (let ((a 'unset) + (b 'unset)) + (pcase-setq `(head ,a ,b) nil) + (list a b)))) + + (should (equal (let (a b) + (pcase-setq `[,a ,b] [1 2]) + (list a b)) + '(1 2))) + + (should-error (let (a b) + (pcase-setq `[,a ,b] nil) + (list a b))) + + (should (equal (let (a b) + (pcase-setq a 1 b 2) + (list a b)) + '(1 2))) + + (should (= (let (a) + (pcase-setq a 1 `(,a) '(2)) + a) + 2)) + + (should (equal (let (array list-item array-copy) + (pcase-setq (or `(,list-item) array) [1 2 3] + array-copy array + ;; This re-sets `array' to nil. + (or `(,list-item) array) '(4)) + (list array array-copy list-item)) + '(nil [1 2 3] 4))) + + (let ((a nil)) + (should-error (pcase-setq a 1 b) + :type '(wrong-number-of-arguments)) + (should (eq a nil))) + + (should-error (pcase-setq a) + :type '(wrong-number-of-arguments))) ;;; pcase-tests.el ends here. diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 63d7c7b91ea..4828df0de92 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -156,6 +156,8 @@ "....."))) (ert-deftest rx-pcase () + (should (equal (pcase "i18n" ((rx (let x (+ digit))) (list 'ok x))) + '(ok "18"))) (should (equal (pcase "a 1 2 3 1 1 b" ((rx (let u (+ digit)) space (let v (+ digit)) space @@ -164,6 +166,20 @@ (backref 1)) (list u v))) '("1" "3"))) + (should (equal (pcase "bz" + ((rx "a" (let x nonl)) (list 1 x)) + (_ 'no)) + 'no)) + (should (equal (pcase "az" + ((rx "a" (let x nonl)) (list 1 x)) + ((rx "b" (let x nonl)) (list 2 x)) + (_ 'no)) + '(1 "z"))) + (should (equal (pcase "bz" + ((rx "a" (let x nonl)) (list 1 x)) + ((rx "b" (let x nonl)) (list 2 x)) + (_ 'no)) + '(2 "z"))) (let ((k "blue")) (should (equal (pcase "<blue>" ((rx "<" (literal k) ">") 'ok)) @@ -171,7 +187,23 @@ (should (equal (pcase "abc" ((rx (? (let x alpha)) (?? (let y alnum)) ?c) (list x y))) - '("a" "b")))) + '("a" "b"))) + (should (equal (pcase 'not-a-string + ((rx nonl) 'wrong) + (_ 'correct)) + 'correct)) + (should (equal (pcase "PQR" + ((and (rx (let a nonl)) (rx ?z)) + (list 'one a)) + ((rx (let b ?Q)) + (list 'two b))) + '(two "Q"))) + (should (equal (pcase-let (((rx ?B (let z nonl)) "ABC")) + (list 'ok z)) + '(ok "C"))) + (should (equal (pcase-let* (((rx ?E (let z nonl)) "DEF")) + (list 'ok z)) + '(ok "F")))) (ert-deftest rx-kleene () "Test greedy and non-greedy repetition operators." @@ -388,6 +420,8 @@ (ert-deftest rx-regexp () (should (equal (rx (regexp "abc") (regex "[de]")) "\\(?:abc\\)[de]")) + (should (equal (rx "a" (regexp "$")) + "a\\(?:$\\)")) (let ((x "a*")) (should (equal (rx (regexp x) "b") "\\(?:a*\\)b")) diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 05c7fbe781e..44e855e2cfa 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -383,6 +383,30 @@ Evaluate BODY for each created sequence. (should (null b)) (should (null c))))) +(ert-deftest test-seq-setq () + (with-test-sequences (seq '(1 2 3 4)) + (let (a b c d e) + (seq-setq (a b c d e) seq) + (should (= a 1)) + (should (= b 2)) + (should (= c 3)) + (should (= d 4)) + (should (null e))) + (let (a b others) + (seq-setq (a b &rest others) seq) + (should (= a 1)) + (should (= b 2)) + (should (same-contents-p others (seq-drop seq 2))))) + (let ((a) + (seq '(1 (2 (3 (4)))))) + (seq-setq (_ (_ (_ (a)))) seq) + (should (= a 4))) + (let (seq a b c) + (seq-setq (a b c) seq) + (should (null a)) + (should (null b)) + (should (null c)))) + (ert-deftest test-seq-min-max () (with-test-sequences (seq '(4 5 3 2 0 4)) (should (= (seq-min seq) 0)) diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el new file mode 100644 index 00000000000..3bb3185649b --- /dev/null +++ b/test/lisp/emacs-lisp/shortdoc-tests.el @@ -0,0 +1,45 @@ +;;; shortdoc-tests.el --- tests for shortdoc.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 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/>. + +(require 'ert) +(require 'shortdoc) + +(defun shortdoc-tests--tree-contains (tree fun) + "Whether TREE contains a call to FUN." + (and (proper-list-p tree) + (or (eq (car tree) fun) + (cl-some (lambda (x) (shortdoc-tests--tree-contains x fun)) tree)))) + +(ert-deftest shortdoc-examples () + "Check that each example actually contains the corresponding form." + (dolist (group shortdoc--groups) + (dolist (item group) + (when (consp item) + (let ((fun (car item)) + (props (cdr item))) + (while props + (when (memq (car props) '(:eval :no-eval :no-eval* :no-value)) + (let* ((example (cadr props)) + (expr (cond + ((consp example) example) + ((stringp example) (read example))))) + (should (shortdoc-tests--tree-contains expr fun)))) + (setq props (cddr props)))))))) + +(provide 'shortdoc-tests) diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index 112f3c1dac1..ef04cde3867 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -607,18 +607,21 @@ (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óá" 4 nil 'utf-8-with-signature) + "fo\303\263")) (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) "\376\377\000f")) + (should (equal (string-limit "foóá" 4 nil 'utf-16) "\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ó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) "\376\377\000\341"))) + (should (equal (string-limit "foóá" 4 t 'utf-16) "\000\363\000\341"))) (ert-deftest subr-string-lines () (should (equal (string-lines "foo") '("foo"))) diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index 5dbf2272b1a..7ced257c6f9 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 9f0312d85ff..7854e33e77d 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: |