diff options
Diffstat (limited to 'test/src')
28 files changed, 3223 insertions, 54 deletions
diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 123f2e8eabb..118311c4d26 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -754,7 +754,7 @@ with parameters from the *Messages* buffer modification." (should-length 2 (overlays-in 1 (point-max))) (should-length 1 (overlays-in (point-max) (point-max))) (narrow-to-region 1 50) - (should-length 0 (overlays-in 1 (point-max))) + (should-length 1 (overlays-in 1 (point-max))) (should-length 1 (overlays-in (point-max) (point-max)))))) @@ -1345,8 +1345,8 @@ with parameters from the *Messages* buffer modification." (add-hook 'kill-buffer-hook kbh nil t) (add-hook 'kill-buffer-query-functions kbqf nil t) (kill-buffer)) - (with-temp-buffer) - (with-output-to-string) + (with-temp-buffer (ignore)) + (with-output-to-string (ignore)) (should-not run-bluh) (should-not run-kbh) (should-not run-kbqf) @@ -1361,4 +1361,63 @@ with parameters from the *Messages* buffer modification." (should run-kbqf)) (remove-hook 'buffer-list-update-hook bluh)))) +(ert-deftest buffer-tests-inhibit-buffer-hooks-indirect () + "Indirect buffers do not call `get-buffer-create'." + (dolist (inhibit '(nil t)) + (let ((base (get-buffer-create "foo" inhibit))) + (unwind-protect + (dotimes (_i 11) + (let* (flag* + (flag (lambda () (prog1 t (setq flag* t)))) + (indirect (make-indirect-buffer base "foo[indirect]" nil + inhibit))) + (unwind-protect + (progn + (with-current-buffer indirect + (add-hook 'kill-buffer-query-functions flag nil t)) + (kill-buffer indirect) + (if inhibit + (should-not flag*) + (should flag*))) + (let (kill-buffer-query-functions) + (when (buffer-live-p indirect) + (kill-buffer indirect)))))) + (let (kill-buffer-query-functions) + (when (buffer-live-p base) + (kill-buffer base))))))) + +(ert-deftest zero-length-overlays-and-not () + (with-temp-buffer + (insert "hello") + (let ((long-overlay (make-overlay 2 4)) + (zero-overlay (make-overlay 3 3))) + ;; Exclude. + (should (= (length (overlays-at 3)) 1)) + (should (eq (car (overlays-at 3)) long-overlay)) + ;; Include. + (should (= (length (overlays-in 3 3)) 2)) + (should (memq long-overlay (overlays-in 3 3))) + (should (memq zero-overlay (overlays-in 3 3)))))) + +(ert-deftest test-remove-overlays () + (with-temp-buffer + (insert "foo") + (make-overlay (point) (point)) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (remove-overlays) + (should (= (length (overlays-in (point-min) (point-max))) 0))) + + (with-temp-buffer + (insert "foo") + (goto-char 2) + (make-overlay (point) (point)) + ;; We only count zero-length overlays at the end of the buffer. + (should (= (length (overlays-in 1 2)) 0)) + (narrow-to-region 1 2) + ;; We've now narrowed, so the zero-length overlay is at the end of + ;; the (accessible part of the) buffer. + (should (= (length (overlays-in 1 2)) 1)) + (remove-overlays) + (should (= (length (overlays-in (point-min) (point-max))) 0)))) + ;;; buffer-tests.el ends here diff --git a/test/src/character-tests.el b/test/src/character-tests.el new file mode 100644 index 00000000000..f630b32a5ee --- /dev/null +++ b/test/src/character-tests.el @@ -0,0 +1,45 @@ +;;; character-tests.el --- tests for character.c -*- 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/>. + +;;; Code: + +(require 'ert) + +(ert-deftest character-test-string-width () + "Test `string-width' with and without compositions." + (should (= (string-width "1234") 4)) + (should (= (string-width "12\t34") (+ 4 tab-width))) + (should (= (string-width "áëòç") 4)) + (should (= (string-width "áëòç") 4)) + (should (= (string-width "הַרְבֵּה אַהֲבָה") 9)) + (should (= (string-width "1234" 1 3) 2)) + (should (= (string-width "1234" nil -1) 3)) + (should (= (string-width "1234" 2) 2)) + (should-error (string-width "1234" nil 5)) + (should-error (string-width "1234" -5)) + (should (= (string-width "12\t34") (+ 4 tab-width))) + (should (= (string-width "1234\t56") (+ 6 tab-width))) + (should (= (string-width "áëòç") 4)) + (should (= (string-width "áëòç" nil 3) 3)) + (should (= (string-width "áëòç" 1 3) 2)) + (should (= (string-width "áëòç" nil 2) 1)) + (should (= (string-width "áëòç" nil 3) 2)) + (should (= (string-width "áëòç" nil 4) 2)) + (should (= (string-width "הַרְבֵּה אַהֲבָה") 9)) + (should (= (string-width "הַרְבֵּה אַהֲבָה" nil 8) 4))) diff --git a/test/src/coding-tests.el b/test/src/coding-tests.el index 0bdcff22ce5..134f5676709 100644 --- a/test/src/coding-tests.el +++ b/test/src/coding-tests.el @@ -56,7 +56,7 @@ (set-buffer-multibyte nil) (insert (encode-coding-string "あ" 'euc-jp) "\xd" "\n") (decode-coding-region (point-min) (point-max) 'euc-jp-dos) - (should-not (string-match-p "\^M" (buffer-string))))) + (should-not (string-search "\^M" (buffer-string))))) ;; Return the contents (specified by CONTENT-TYPE; ascii, latin, or ;; binary) of a test file. @@ -359,7 +359,7 @@ (delete-region (point-min) (point)))))) (defun benchmark-decoder () - (let ((gc-cons-threshold 4000000)) + (let ((gc-cons-threshold (max gc-cons-threshold 4000000))) (insert "Without optimization:\n") (dolist (files test-file-list) (dolist (file (cdr files)) diff --git a/test/src/comp-resources/comp-test-45603.el b/test/src/comp-resources/comp-test-45603.el new file mode 100644 index 00000000000..f1c0dafb68d --- /dev/null +++ b/test/src/comp-resources/comp-test-45603.el @@ -0,0 +1,28 @@ +;;; -*- lexical-binding: t; -*- + +;; Reduced from ivy.el. + +(defvar comp-test-45603-last) +(defvar comp-test-45603-mark-prefix) +(defvar comp-test-45603-directory) +(defvar comp-test-45603-marked-candidates) + +(defun comp-test-45603--call-marked (action) + (let* ((prefix-len (length comp-test-45603-mark-prefix)) + (marked-candidates + (mapcar + (lambda (s) + (let ((cand (substring s prefix-len))) + (if comp-test-45603-directory + (expand-file-name cand comp-test-45603-directory) + cand))) + comp-test-45603-marked-candidates)) + (multi-action (comp-test-45603--get-multi-action comp-test-45603-last))))) + +(defalias 'comp-test-45603--file-local-name + (if (fboundp 'file-local-name) + #'file-local-name + (lambda (file) + (or (file-remote-p file 'localname) file)))) + +(provide 'comp-test-45603) diff --git a/test/src/comp-resources/comp-test-funcs-dyn.el b/test/src/comp-resources/comp-test-funcs-dyn.el new file mode 100644 index 00000000000..3118455e3f6 --- /dev/null +++ b/test/src/comp-resources/comp-test-funcs-dyn.el @@ -0,0 +1,50 @@ +;;; comp-test-funcs-dyn.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*- + +;; 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: + +;;; Code: + +(require 'cl-lib) + +(defun comp-tests-ffuncall-callee-dyn-f (a b) + (list a b)) + +(defun comp-tests-ffuncall-callee-opt-dyn-f (a b &optional c d) + (list a b c d)) + +(defun comp-tests-ffuncall-callee-rest-dyn-f (a b &rest c) + (list a b c)) + +(defun comp-tests-ffuncall-callee-opt-rest-dyn-f (a b &optional c &rest d) + (list a b c d)) + +(defun comp-tests-cl-macro-exp-f () + (cl-loop for xxx in '(a b) + for yyy = xxx + collect xxx)) + +(cl-defun comp-tests-cl-uninterned-arg-parse-f (a &optional b &aux) + (list a b)) + +(provide 'comp-test-dyn-funcs) + +;;; comp-test-funcs-dyn.el ends here diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el new file mode 100644 index 00000000000..f2a246320ac --- /dev/null +++ b/test/src/comp-resources/comp-test-funcs.el @@ -0,0 +1,710 @@ +;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2019-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: + +;;; Code: + +(defvar comp-tests-var1 3) + +(defun comp-tests-varref-f () + comp-tests-var1) + +(defun comp-tests-list-f () + (list 1 2 3)) +(defun comp-tests-list2-f (a b c) + (list a b c)) +(defun comp-tests-car-f (x) + ;; Bcar + (car x)) +(defun comp-tests-cdr-f (x) + ;; Bcdr + (cdr x)) +(defun comp-tests-car-safe-f (x) + ;; Bcar_safe + (car-safe x)) +(defun comp-tests-cdr-safe-f (x) + ;; Bcdr_safe + (cdr-safe x)) + +(defun comp-tests-cons-car-f () + (car (cons 1 2))) +(defun comp-tests-cons-cdr-f (x) + (cdr (cons 'foo x))) + +(defun comp-tests-hint-fixnum-f (n) + (1+ (comp-hint-fixnum n))) + +(defun comp-tests-hint-cons-f (c) + (car (comp-hint-cons c))) + +(defun comp-tests-varset0-f () + (setq comp-tests-var1 55)) +(defun comp-tests-varset1-f () + (setq comp-tests-var1 66) + 4) + +(defun comp-tests-length-f () + (length '(1 2 3))) + +(defun comp-tests-aref-aset-f () + (let ((vec (make-vector 3 0))) + (aset vec 2 100) + (aref vec 2))) + +(defvar comp-tests-var2 3) +(defun comp-tests-symbol-value-f () + (symbol-value 'comp-tests-var2)) + +(defun comp-tests-concat-f (x) + (concat "a" "b" "c" "d" + (concat "a" "b" "c" (concat "a" "b" (concat "foo" x))))) + +(defun comp-tests-ffuncall-callee-f (x y z) + (list x y z)) + +(defun comp-tests-ffuncall-callee-optional-f (a b &optional c d) + (list a b c d)) + +(defun comp-tests-ffuncall-callee-rest-f (a b &rest c) + (list a b c)) + +(defun comp-tests-ffuncall-callee-more8-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 p10) + ;; More then 8 args. + (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)) + +(defun comp-tests-ffuncall-callee-more8-rest-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 &rest p10) + ;; More then 8 args. + (list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)) + +(defun comp-tests-ffuncall-native-f () + "Call a primitive with no dedicate op." + (make-vector 1 nil)) + +(defun comp-tests-ffuncall-native-rest-f () + "Call a primitive with no dedicate op with &rest." + (vector 1 2 3)) + +(defun comp-tests-ffuncall-apply-many-f (x) + (apply #'list x)) + +(defun comp-tests-ffuncall-lambda-f (x) + (let ((fun (lambda (x) + (1+ x)))) + (funcall fun x))) + +(defun comp-tests-jump-table-1-f (x) + (pcase x + ('x 'a) + ('y 'b) + (_ 'c))) + +(defun comp-tests-jump-table-2-f (x) + (pcase x + ("aaa" 'a) + ("bbb" 'b))) + +(defun comp-tests-conditionals-1-f (x) + ;; Generate goto-if-nil + (if x 1 2)) +(defun comp-tests-conditionals-2-f (x) + ;; Generate goto-if-nil-else-pop + (when x + 1340)) + +(defun comp-tests-fixnum-1-minus-f (x) + ;; Bsub1 + (1- x)) +(defun comp-tests-fixnum-1-plus-f (x) + ;; Badd1 + (1+ x)) +(defun comp-tests-fixnum-minus-f (x) + ;; Bnegate + (- x)) + +(defun comp-tests-eqlsign-f (x y) + ;; Beqlsign + (= x y)) +(defun comp-tests-gtr-f (x y) + ;; Bgtr + (> x y)) +(defun comp-tests-lss-f (x y) + ;; Blss + (< x y)) +(defun comp-tests-les-f (x y) + ;; Bleq + (<= x y)) +(defun comp-tests-geq-f (x y) + ;; Bgeq + (>= x y)) + +(defun comp-tests-setcar-f (x y) + (setcar x y) + x) +(defun comp-tests-setcdr-f (x y) + (setcdr x y) + x) + +(defun comp-bubble-sort-f (list) + (let ((i (length list))) + (while (> i 1) + (let ((b list)) + (while (cdr b) + (when (< (cadr b) (car b)) + (setcar b (prog1 (cadr b) + (setcdr b (cons (car b) (cddr b)))))) + (setq b (cdr b)))) + (setq i (1- i))) + list)) + +(defun comp-tests-consp-f (x) + ;; Bconsp + (consp x)) +(defun comp-tests-setcar2-f (x) + ;; Bsetcar + (setcar x 3)) + +(defun comp-tests-integerp-f (x) + ;; Bintegerp + (integerp x)) +(defun comp-tests-numberp-f (x) + ;; Bnumberp + (numberp x)) + +(defun comp-tests-discardn-f (x) + ;; BdiscardN + (1+ (let ((a 1) + (_b) + (_c)) + a))) +(defun comp-tests-insertn-f (a b c d) + ;; Binsert + (insert a b c d)) + +(defun comp-tests-err-arith-f () + (/ 1 0)) +(defun comp-tests-err-foo-f () + (error "foo")) + +(defun comp-tests-condition-case-0-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-arith-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) +(defun comp-tests-condition-case-1-f () + ;; Bpushhandler Bpophandler + (condition-case + err + (comp-tests-err-foo-f) + (arith-error (concat "arith-error " + (error-message-string err) + " catched")) + (error (concat "error " + (error-message-string err) + " catched")))) +(defun comp-tests-catch-f (f) + (catch 'foo + (funcall f))) +(defun comp-tests-throw-f (x) + (throw 'foo x)) + +(defun comp-tests-buff0-f () + (with-temp-buffer + (insert "foo") + (buffer-string))) + +(defun comp-tests-lambda-return-f () + (lambda (x) (1+ x))) + +(defun comp-tests-fib-f (n) + (cond ((= n 0) 0) + ((= n 1) 1) + (t (+ (comp-tests-fib-f (- n 1)) + (comp-tests-fib-f (- n 2)))))) + +(defmacro comp-tests-macro-m (x) + x) + +(defun comp-tests-string-trim-f (url) + (string-trim url)) + +(defun comp-tests-trampoline-removal-f () + (make-hash-table)) + +(defun comp-tests-signal-f () + (signal 'foo t)) + +(defun comp-tests-func-call-removal-f () + (let ((a 10) + (b 3)) + (% a b))) + +(defun comp-tests-doc-f () + "A nice docstring" + t) + +(defun comp-test-interactive-form0-f (dir) + (interactive "D") + dir) + +(defun comp-test-interactive-form1-f (x y) + (interactive '(1 2)) + (+ x y)) + +(defun comp-test-interactive-form2-f () + (interactive)) + +(defun comp-test-40187-2-f () + 'foo) + +(defalias 'comp-test-40187-1-f (symbol-function 'comp-test-40187-2-f)) + +(defun comp-test-40187-2-f () + 'bar) + +(defun comp-test-speed--1-f () + (declare (speed -1)) + 3) + +(defun comp-test-42360-f (str end-column + &optional start-column padding ellipsis + ellipsis-text-property) + ;; From `truncate-string-to-width'. A large enough function to + ;; potentially use all registers and that is modifying local + ;; variables inside condition-case. + (let ((str-len (length str)) + (str-width 14) + (ellipsis-width 3) + (idx 0) + (column 0) + (head-padding "") (tail-padding "") + ch last-column last-idx from-idx) + (condition-case nil + (while (< column start-column) + (setq ch (aref str idx) + column (+ column (char-width ch)) + idx (1+ idx))) + (args-out-of-range (setq idx str-len))) + (if (< column start-column) + (if padding (make-string end-column padding) "") + (when (and padding (> column start-column)) + (setq head-padding (make-string (- column start-column) padding))) + (setq from-idx idx) + (when (>= end-column column) + (condition-case nil + (while (< column end-column) + (setq last-column column + last-idx idx + ch (aref str idx) + column (+ column (char-width ch)) + idx (1+ idx))) + (args-out-of-range (setq idx str-len))) + (when (> column end-column) + (setq column last-column + idx last-idx)) + (when (and padding (< column end-column)) + (setq tail-padding (make-string (- end-column column) padding)))) + (if (and ellipsis-text-property + (not (equal ellipsis "")) + idx) + (concat head-padding + (substring str from-idx idx) + (propertize (substring str idx) 'display (or ellipsis ""))) + (concat head-padding (substring str from-idx idx) + tail-padding ellipsis))))) + +(defun comp-test-primitive-advice-f (x y) + (declare (speed 2)) + (+ x y)) + +(defun comp-test-primitive-redefine-f (x y) + (declare (speed 2)) + (- x y)) + +(defsubst comp-test-defsubst-f () + t) + +(defvar comp-test-and-3-var 1) +(defun comp-test-and-3-f (x) + (and (atom x) + comp-test-and-3-var + 2)) + +(defun comp-test-copy-insn-f (insn) + ;; From `comp-copy-insn'. + (if (consp insn) + (let (result) + (while (consp insn) + (let ((newcar (car insn))) + (if (or (consp (car insn)) (comp-mvar-p (car insn))) + (setf newcar (comp-copy-insn (car insn)))) + (push newcar result)) + (setf insn (cdr insn))) + (nconc (nreverse result) + (if (comp-mvar-p insn) (comp-copy-insn insn) insn))) + (if (comp-mvar-p insn) + (copy-comp-mvar insn) + insn))) + +(defun comp-test-cond-rw-1-1-f ()) + +(defun comp-test-cond-rw-1-2-f () + (let ((it (comp-test-cond-rw-1-1-f)) + (key 't)) + (if (or (equal it key) + (eq key t)) + it + nil))) + +(defun comp-test-44968-f (start end) + (let ((dirlist) + (dir (expand-file-name start)) + (end (expand-file-name end))) + (while (not (or (equal dir (car dirlist)) + (file-equal-p dir end))) + (push dir dirlist) + (setq dir (directory-file-name (file-name-directory dir)))) + (nreverse dirlist))) + +(defun comp-test-45342-f (n) + (pcase n + (1 " ➊") (2 " ➋") (3 " ➌") (4 " ➍") (5 " ➎") (6 " ➏") + (7 " ➐") (8 " ➑") (9 " ➒") (10 " ➓") (_ ""))) + +(defun comp-test-assume-double-neg-f (collection value) + ;; Reduced from `auth-source-search-collection'. + (when (atom collection) + (setq collection (list collection))) + (or (eq value t) + ;; value is (not (member t)) + (eq collection value) + ;; collection is t, not (member t)! + (member value collection))) + +(defun comp-test-assume-in-loop-1-f (arg) + ;; Reduced from `comint-delim-arg'. + (let ((args nil) + (pos 0) + (len (length arg))) + (while (< pos len) + (let ((start pos)) + (while (< pos len) + (setq pos (1+ pos))) + (setq args (cons (substring arg start pos) args)))) + args)) + +(defun comp-test-45376-1-f () + ;; Reduced from `eshell-ls-find-column-lengths'. + (let* (res + (len 2) + (i 0) + (j 0)) + (while (< j len) + (if (= i len) + (setq i 0)) + (setq res (cons i res) + j (1+ j) + i (1+ i))) + res)) + +(defun comp-test-45376-2-f () + ;; Also reduced from `eshell-ls-find-column-lengths'. + (let* ((x 1) + res) + (while x + (let* ((y 4) + (i 0)) + (while (> y 0) + (when (= i x) + (setq i 0)) + (setf res (cons i res)) + (setq y (1- y) + i (1+ i))) + (if (>= x 3) + (setq x nil) + (setq x (1+ x))))) + res)) + +(defun comp-test-not-cons-f (x) + ;; Reduced from `cl-copy-list'. + (if (consp x) + (print x) + (car x))) + +(defun comp-test-45576-f () + ;; Reduced from `eshell-find-alias-function'. + (let ((sym (intern-soft "eval"))) + (if (and (functionp sym) + '(eshell-ls eshell-pred eshell-prompt eshell-script + eshell-term eshell-unix)) + sym))) + +(defun comp-test-45635-f (&rest args) + ;; Reduced from `set-face-attribute'. + (let ((spec args) + family) + (while spec + (cond ((eq (car spec) :family) + (setq family (cadr spec)))) + (setq spec (cddr spec))) + (when (and (stringp family) + (string-match "\\([^-]*\\)-\\([^-]*\\)" family)) + (setq family (match-string 2 family))) + (when (or (stringp family) + (eq family 'unspecified)) + family))) + +(defun comp-test-46670-1-f (_) + "foo") + +(defun comp-test-46670-2-f (s) + (and (equal (comp-test-46670-1-f (length s)) s) + s)) + +(cl-defun comp-test-46824-1-f () + (let ((next-repos '(1))) + (while t + (let ((recipe (car next-repos))) + (cl-block loop + (while t + (let ((err + (condition-case e + (progn + (setq next-repos + (cdr next-repos)) + (cl-return-from loop)) + (error e)))) + (format "%S" + (error-message-string err)))))) + (cl-return-from comp-test-46824-1-f)))) + +(defun comp-test-47868-1-f () + " ") + +(defun comp-test-47868-2-f () + #(" " 0 1 (face font-lock-keyword-face))) + +(defun comp-test-47868-3-f () + " ") + +(defun comp-test-47868-4-f () + #(" " 0 1 (face font-lock-keyword-face))) + + + +;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests ;; +;;;;;;;;;;;;;;;;;;;; + +;; Test Bconsp. +(defun comp-test-consp (x) (consp x)) + +;; Test Blistp. +(defun comp-test-listp (x) (listp x)) + +;; Test Bstringp. +(defun comp-test-stringp (x) (stringp x)) + +;; Test Bsymbolp. +(defun comp-test-symbolp (x) (symbolp x)) + +;; Test Bintegerp. +(defun comp-test-integerp (x) (integerp x)) + +;; Test Bnumberp. +(defun comp-test-numberp (x) (numberp x)) + +;; Test Badd1. +(defun comp-test-add1 (x) (1+ x)) + +;; Test Bsub1. +(defun comp-test-sub1 (x) (1- x)) + +;; Test Bneg. +(defun comp-test-negate (x) (- x)) + +;; Test Bnot. +(defun comp-test-not (x) (not x)) + +;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max. +(defun comp-test-bobp () (bobp)) +(defun comp-test-eobp () (eobp)) +(defun comp-test-point () (point)) +(defun comp-test-point-min () (point-min)) +(defun comp-test-point-max () (point-max)) + +;; Test Bcar and Bcdr. +(defun comp-test-car (x) (car x)) +(defun comp-test-cdr (x) (cdr x)) + +;; Test Bcar_safe and Bcdr_safe. +(defun comp-test-car-safe (x) (car-safe x)) +(defun comp-test-cdr-safe (x) (cdr-safe x)) + +;; Test Beq. +(defun comp-test-eq (x y) (eq x y)) + +;; Test Bgotoifnil. +(defun comp-test-if (x y) (if x x y)) + +;; Test Bgotoifnilelsepop. +(defun comp-test-and (x y) (and x y)) + +;; Test Bgotoifnonnilelsepop. +(defun comp-test-or (x y) (or x y)) + +;; Test Bsave_excursion. +(defun comp-test-save-excursion () + (save-excursion + (insert "XYZ"))) + +;; Test Bcurrent_buffer. +(defun comp-test-current-buffer () (current-buffer)) + +;; Test Bgtr. +(defun comp-test-> (a b) + (> a b)) + +;; Test Bpushcatch. +(defun comp-test-catch (&rest l) + (catch 'done + (dolist (v l) + (when (> v 23) + (throw 'done v))))) + +;; Test Bmemq. +(defun comp-test-memq (val list) + (memq val list)) + +;; Test BlistN. +(defun comp-test-listN (x) + (list x x x x x x x x x x x x x x x x)) + +;; Test BconcatN. +(defun comp-test-concatN (x) + (concat x x x x x x)) + +;; Test optional and rest arguments. +(defun comp-test-opt-rest (a &optional b &rest c) + (list a b c)) + +;; Test for too many arguments. +(defun comp-test-opt (a &optional b) + (cons a b)) + +;; Test for unwind-protect. +(defvar comp-test-up-val nil) +(defun comp-test-unwind-protect (fun) + (setq comp-test-up-val nil) + (unwind-protect + (progn + (setq comp-test-up-val 23) + (funcall fun) + (setq comp-test-up-val 24)) + (setq comp-test-up-val 999))) + +;; Non tested functions that proved just to be difficult to compile. + +(defun comp-test-callee (_ __) t) +(defun comp-test-silly-frame1 (x) + ;; Check robustness against dead code. + (cl-case x + (0 (comp-test-callee + (pcase comp-tests-var1 + (1 1) + (2 2)) + 3)))) + +(defun comp-test-silly-frame2 (token) + ;; Check robustness against dead code. + (while c + (cl-case c + (?< 1) + (?> 2)))) + +(defun comp-test-big-interactive (filename &optional force arg load) + ;; Check non trivial interactive form using `byte-recompile-file'. + (interactive + (let ((file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and file + (derived-mode-p 'emacs-lisp-mode) + (setq file-name (file-name-nondirectory file) + file-dir (file-name-directory file))) + (list (read-file-name (if current-prefix-arg + "Byte compile file: " + "Byte recompile file: ") + file-dir file-name nil) + current-prefix-arg))) + (let ((dest (byte-compile-dest-file filename)) + ;; Expand now so we get the current buffer's defaults + (filename (expand-file-name filename))) + (if (if (file-exists-p dest) + ;; File was already compiled + ;; Compile if forced to, or filename newer + (or force + (file-newer-than-file-p filename dest)) + (and arg + (or (eq 0 arg) + (y-or-n-p (concat "Compile " + filename "? "))))) + (progn + (if (and noninteractive (not byte-compile-verbose)) + (message "Compiling %s..." filename)) + (byte-compile-file filename load)) + (when load + (load (if (file-exists-p dest) dest filename))) + 'no-byte-compile))) + +(defun comp-test-no-return-1 (x) + (while x + (error "foo"))) + +(defun comp-test-no-return-2 (x) + (cond + ((eql x '2) t) + ((error "bar") nil))) + +(defun comp-test-no-return-3 ()) +(defun comp-test-no-return-4 (x) + (when x + (error "foo") + (while (comp-test-no-return-3) + (comp-test-no-return-3)))) + +(defun comp-test-=-nan (x) + (when (= x 0.0e+NaN) + x)) + +(defun comp-test-=-infinity (x) + (when (= x 1.0e+INF) + x)) + +(provide 'comp-test-funcs) + +;;; comp-test-funcs.el ends here diff --git a/test/src/comp-resources/comp-test-pure.el b/test/src/comp-resources/comp-test-pure.el new file mode 100644 index 00000000000..5c1d2d17472 --- /dev/null +++ b/test/src/comp-resources/comp-test-pure.el @@ -0,0 +1,40 @@ +;;; comp-test-pure.el --- compilation unit tested by comp-tests.el -*- 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: + +;;; Code: + +(defun comp-tests-pure-callee-f (x) + (1+ x)) + +(defun comp-tests-pure-caller-f () + (comp-tests-pure-callee-f 3)) + +(defun comp-tests-pure-fibn-f (a b count) + (if (= count 0) + b + (comp-tests-pure-fibn-f (+ a b) a (- count 1)))) + +(defun comp-tests-pure-fibn-entry-f () + (comp-tests-pure-fibn-f 1 0 20)) + +;;; comp-test-pure.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el new file mode 100644 index 00000000000..fb9441eb66e --- /dev/null +++ b/test/src/comp-tests.el @@ -0,0 +1,1443 @@ +;;; comp-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2019-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 src/comp.c. + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'cl-lib) + +(defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) + +(defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el")) + +(when (featurep 'native-compile) + (require 'comp) + (message "Compiling tests...") + (load (native-compile comp-test-src)) + (load (native-compile comp-test-dyn-src))) + +(defmacro comp-deftest (name args &rest docstring-and-body) + "Define a test for the native compiler tagging it as :nativecomp." + (declare (indent defun) + (doc-string 3)) + `(ert-deftest ,(intern (concat "comp-tests-" (symbol-name name))) ,args + :tags '(:nativecomp) + ,@docstring-and-body)) + + + +(ert-deftest comp-tests-bootstrap () + "Compile the compiler and load it to compile it-self. +Check that the resulting binaries do not differ." + :tags '(:expensive-test :nativecomp) + (let* ((byte+native-compile t) ; FIXME HACK + (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el" + (ert-resource-directory))) + (comp1-src (make-temp-file "stage1-" nil ".el")) + (comp2-src (make-temp-file "stage2-" nil ".el")) + ;; Can't use debug symbols. + (native-comp-debug 0)) + (copy-file comp-src comp1-src t) + (copy-file comp-src comp2-src t) + (let ((load-no-native t)) + (load (concat comp-src "c") nil nil t t)) + (should-not (subr-native-elisp-p (symbol-function #'native-compile))) + (message "Compiling stage1...") + (let* ((t0 (current-time)) + (comp1-eln (native-compile comp1-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (load comp1-eln nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (let ((t0 (current-time)) + (comp2-eln (native-compile comp2-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (message "Comparing %s %s" comp1-eln comp2-eln) + (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) + +(comp-deftest provide () + "Testing top level provide." + (should (featurep 'comp-test-funcs))) + +(comp-deftest varref () + "Testing varref." + (should (= (comp-tests-varref-f) 3))) + +(comp-deftest list () + "Testing cons car cdr." + (should (equal (comp-tests-list-f) '(1 2 3))) + (should (equal (comp-tests-list2-f 1 2 3) '(1 2 3))) + (should (= (comp-tests-car-f '(1 . 2)) 1)) + (should (null (comp-tests-car-f nil))) + (should-error (comp-tests-car-f 3) + :type 'wrong-type-argument) + (should (= (comp-tests-cdr-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-f nil))) + (should-error (comp-tests-cdr-f 3) + :type 'wrong-type-argument) + (should (= (comp-tests-car-safe-f '(1 . 2)) 1)) + (should (null (comp-tests-car-safe-f 'a))) + (should (= (comp-tests-cdr-safe-f '(1 . 2)) 2)) + (should (null (comp-tests-cdr-safe-f 'a)))) + +(comp-deftest comp-tests-cons-car-cdr () + "Testing cons car cdr." + (should (= (comp-tests-cons-car-f) 1)) + (should (= (comp-tests-cons-cdr-f 3) 3))) + +(comp-deftest varset () + "Testing varset." + (comp-tests-varset0-f) + (should (= comp-tests-var1 55)) + + (should (= (comp-tests-varset1-f) 4)) + (should (= comp-tests-var1 66))) + +(comp-deftest length () + "Testing length." + (should (= (comp-tests-length-f) 3))) + +(comp-deftest aref-aset () + "Testing aref and aset." + (should (= (comp-tests-aref-aset-f) 100))) + +(comp-deftest symbol-value () + "Testing aref and aset." + (should (= (comp-tests-symbol-value-f) 3))) + +(comp-deftest concat () + "Testing concatX opcodes." + (should (string= (comp-tests-concat-f "bar") "abcdabcabfoobar"))) + +(comp-deftest ffuncall () + "Test calling conventions." + + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) + + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + ;; ;; After it gets compiled + ;; (native-compile #'comp-tests-ffuncall-callee-f) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + ;; ;; Recompiling the caller once with callee already compiled + ;; (defun comp-tests-ffuncall-caller-f () + ;; (comp-tests-ffuncall-callee-f 1 2 3)) + ;; (should (equal (comp-tests-ffuncall-caller-f) '(1 2 3))) + + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3 4) + '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-optional-f 1 2) + '(1 2 nil nil))) + + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2) + '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3) + '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-f 1 2 3 4) + '(1 2 (3 4)))) + + (should (equal (comp-tests-ffuncall-callee-more8-f 1 2 3 4 5 6 7 8 9 10) + '(1 2 3 4 5 6 7 8 9 10))) + + (should (equal (comp-tests-ffuncall-callee-more8-rest-f 1 2 3 4 5 6 7 8 9 10 11) + '(1 2 3 4 5 6 7 8 9 (10 11)))) + + (should (equal (comp-tests-ffuncall-native-f) [nil])) + + (should (equal (comp-tests-ffuncall-native-rest-f) [1 2 3])) + + (should (equal (comp-tests-ffuncall-apply-many-f '(1 2 3)) + '(1 2 3))) + + (should (= (comp-tests-ffuncall-lambda-f 1) 2))) + +(comp-deftest jump-table () + "Testing jump tables" + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c)) + + ;; Jump table not with eq as test + (should (eq (comp-tests-jump-table-2-f "aaa") 'a)) + (should (eq (comp-tests-jump-table-2-f "bbb") 'b))) + +(comp-deftest conditionals () + "Testing conditionals." + (should (= (comp-tests-conditionals-1-f t) 1)) + (should (= (comp-tests-conditionals-1-f nil) 2)) + (should (= (comp-tests-conditionals-2-f t) 1340)) + (should (eq (comp-tests-conditionals-2-f nil) nil))) + +(comp-deftest fixnum () + "Testing some fixnum inline operation." + (should (= (comp-tests-fixnum-1-minus-f 10) 9)) + (should (= (comp-tests-fixnum-1-minus-f most-negative-fixnum) + (1- most-negative-fixnum))) + (should-error (comp-tests-fixnum-1-minus-f 'a) + :type 'wrong-type-argument) + (should (= (comp-tests-fixnum-1-plus-f 10) 11)) + (should (= (comp-tests-fixnum-1-plus-f most-positive-fixnum) + (1+ most-positive-fixnum))) + (should-error (comp-tests-fixnum-1-plus-f 'a) + :type 'wrong-type-argument) + (should (= (comp-tests-fixnum-minus-f 10) -10)) + (should (= (comp-tests-fixnum-minus-f most-negative-fixnum) + (- most-negative-fixnum))) + (should-error (comp-tests-fixnum-minus-f 'a) + :type 'wrong-type-argument)) + +(comp-deftest type-hints () + "Just test compiler hints are transparent in this case." + ;; FIXME we should really check they are also effective. + (should (= (comp-tests-hint-fixnum-f 3) 4)) + (should (= (comp-tests-hint-cons-f (cons 1 2)) 1))) + +(comp-deftest arith-comp () + "Testing arithmetic comparisons." + (should (eq (comp-tests-eqlsign-f 4 3) nil)) + (should (eq (comp-tests-eqlsign-f 3 3) t)) + (should (eq (comp-tests-eqlsign-f 2 3) nil)) + (should (eq (comp-tests-gtr-f 4 3) t)) + (should (eq (comp-tests-gtr-f 3 3) nil)) + (should (eq (comp-tests-gtr-f 2 3) nil)) + (should (eq (comp-tests-lss-f 4 3) nil)) + (should (eq (comp-tests-lss-f 3 3) nil)) + (should (eq (comp-tests-lss-f 2 3) t)) + (should (eq (comp-tests-les-f 4 3) nil)) + (should (eq (comp-tests-les-f 3 3) t)) + (should (eq (comp-tests-les-f 2 3) t)) + (should (eq (comp-tests-geq-f 4 3) t)) + (should (eq (comp-tests-geq-f 3 3) t)) + (should (eq (comp-tests-geq-f 2 3) nil))) + +(comp-deftest setcarcdr () + "Testing setcar setcdr." + (should (equal (comp-tests-setcar-f '(10 . 10) 3) '(3 . 10))) + (should (equal (comp-tests-setcdr-f '(10 . 10) 3) '(10 . 3))) + (should-error (comp-tests-setcar-f 3 10) + :type 'wrong-type-argument) + (should-error (comp-tests-setcdr-f 3 10) + :type 'wrong-type-argument)) + +(comp-deftest bubble-sort () + "Run bubble sort." + (let* ((list1 (mapcar #'random (make-list 1000 most-positive-fixnum))) + (list2 (copy-sequence list1))) + (should (equal (comp-bubble-sort-f list1) + (sort list2 #'<))))) + +(comp-deftest apply () + "Test some inlined list functions." + (should (eq (comp-tests-consp-f '(1)) t)) + (should (eq (comp-tests-consp-f 1) nil)) + (let ((x (cons 1 2))) + (should (= (comp-tests-setcar2-f x) 3)) + (should (equal x '(3 . 2))))) + +(comp-deftest num-inline () + "Test some inlined number functions." + (should (eq (comp-tests-integerp-f 1) t)) + (should (eq (comp-tests-integerp-f '(1)) nil)) + (should (eq (comp-tests-integerp-f 3.5) nil)) + (should (eq (comp-tests-integerp-f (1+ most-negative-fixnum)) t)) + + (should (eq (comp-tests-numberp-f 1) t)) + (should (eq (comp-tests-numberp-f 'a) nil)) + (should (eq (comp-tests-numberp-f 3.5) t))) + +(comp-deftest stack () + "Test some stack operation." + (should (= (comp-tests-discardn-f 10) 2)) + (should (string= (with-temp-buffer + (comp-tests-insertn-f "a" "b" "c" "d") + (buffer-string)) + "abcd"))) + +(comp-deftest non-locals () + "Test non locals." + (should (string= (comp-tests-condition-case-0-f) + "arith-error Arithmetic error catched")) + (should (string= (comp-tests-condition-case-1-f) + "error foo catched")) + (should (= (comp-tests-catch-f + (lambda () (throw 'foo 3))) + 3)) + (should (= (catch 'foo + (comp-tests-throw-f 3))))) + +(comp-deftest gc () + "Try to do some longer computation to let the GC kick in." + (dotimes (_ 100000) + (comp-tests-cons-cdr-f 3)) + (should (= (comp-tests-cons-cdr-f 3) 3))) + +(comp-deftest buffer () + (should (string= (comp-tests-buff0-f) "foo"))) + +(comp-deftest lambda-return () + (let ((f (comp-tests-lambda-return-f))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 3) 4)))) + +(comp-deftest recursive () + (should (= (comp-tests-fib-f 10) 55))) + +(comp-deftest macro () + "Just check we can define macros" + (should (macrop (symbol-function 'comp-tests-macro-m)))) + +(comp-deftest string-trim () + (should (string= (comp-tests-string-trim-f "dsaf ") "dsaf"))) + +(comp-deftest trampoline-removal () + ;; This tests that we can call primitives with no dedicated bytecode. + ;; At speed >= 2 the trampoline will not be used. + (should (hash-table-p (comp-tests-trampoline-removal-f)))) + +(comp-deftest signal () + (should (equal (condition-case err + (comp-tests-signal-f) + (t err)) + '(foo . t)))) + +(comp-deftest func-call-removal () + ;; See `comp-propagate-insn' `comp-function-call-remove'. + (should (= (comp-tests-func-call-removal-f) 1))) + +(comp-deftest doc () + (should (string= (documentation #'comp-tests-doc-f) + "A nice docstring")) + ;; Check a preloaded function, we can't use `comp-tests-doc-f' now + ;; as this is loaded manually with no .elc. + (should (string-match "\\.*.elc\\'" (symbol-file #'error)))) + +(comp-deftest interactive-form () + (should (equal (interactive-form #'comp-test-interactive-form0-f) + '(interactive "D"))) + (should (equal (interactive-form #'comp-test-interactive-form1-f) + '(interactive '(1 2)))) + (should (equal (interactive-form #'comp-test-interactive-form2-f) + '(interactive nil))) + (should (cl-every #'commandp '(comp-test-interactive-form0-f + comp-test-interactive-form1-f + comp-test-interactive-form2-f))) + (should-not (commandp #'comp-tests-doc-f))) + +(comp-deftest free-fun () + "Check we are able to compile a single function." + (eval '(defun comp-tests-free-fun-f () + "Some doc." + (interactive) + 3) + t) + (native-compile #'comp-tests-free-fun-f) + + (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) + (should (= (comp-tests-free-fun-f) 3)) + (should (string= (documentation #'comp-tests-free-fun-f) + "Some doc.")) + (should (commandp #'comp-tests-free-fun-f)) + (should (equal (interactive-form #'comp-tests-free-fun-f) + '(interactive)))) + +(comp-deftest free-fun-silly-name () + "Check we are able to compile a single function." + (eval '(defun comp-tests/free\fun-f ()) t) + (native-compile #'comp-tests/free\fun-f) + (should (subr-native-elisp-p (symbol-function #'comp-tests/free\fun-f)))) + +(comp-deftest bug-40187 () + "Check function name shadowing. +https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." + (should (eq (comp-test-40187-1-f) 'foo)) + (should (eq (comp-test-40187-2-f) 'bar))) + +(comp-deftest speed--1 () + "Check that at speed -1 we do not native compile." + (should (= (comp-test-speed--1-f) 3)) + (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) + +(comp-deftest bug-42360 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-07/msg00418.html>." + (should (string= (comp-test-42360-f "Nel mezzo del " 18 0 32 "yyy" nil) + "Nel mezzo del yyy"))) + +(comp-deftest bug-44968 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-11/msg02357.html>" + (comp-test-44968-f "/tmp/test/foo" "/tmp")) + +(comp-deftest bug-45342 () + "Preserve multibyte immediate strings. +<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01771.html>" + (should (string= " ➊" (comp-test-45342-f 1)))) + +(comp-deftest assume-double-neg () + "In fwprop assumptions (not (not (member x))) /= (member x)." + (should-not (comp-test-assume-double-neg-f "bar" "foo"))) + +(comp-deftest assume-in-loop-1 () + "Broken call args assumptions lead to infinite loop." + (should (equal (comp-test-assume-in-loop-1-f "cd") '("cd")))) + +(comp-deftest bug-45376-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01883.html>" + (should (equal (comp-test-45376-1-f) '(1 0)))) + +(comp-deftest bug-45376-2 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01883.html>" + (should (equal (comp-test-45376-2-f) '(0 2 1 0 1 0 1 0 0 0 0 0)))) + +(defvar comp-test-primitive-advice) +(comp-deftest primitive-advice () + "Test effectiveness of primitive advising." + (let (comp-test-primitive-advice + (f (lambda (&rest args) + (setq comp-test-primitive-advice args)))) + (advice-add #'+ :before f) + (unwind-protect + (progn + (should (= (comp-test-primitive-advice-f 3 4) 7)) + (should (equal comp-test-primitive-advice '(3 4)))) + (advice-remove #'+ f)))) + +(defvar comp-test-primitive-redefine-args) +(comp-deftest primitive-redefine () + "Test effectiveness of primitive redefinition." + (cl-letf ((comp-test-primitive-redefine-args nil) + ((symbol-function #'-) + (lambda (&rest args) + (setq comp-test-primitive-redefine-args args) + 'xxx))) + (should (eq (comp-test-primitive-redefine-f 10 2) 'xxx)) + (should (equal comp-test-primitive-redefine-args '(10 2))))) + +(comp-deftest compile-forms () + "Verify lambda form native compilation." + (should-error (native-compile '(+ 1 foo))) + (let ((lexical-binding t) + (f (native-compile '(lambda (x) (1+ x))))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 2) 3))) + (let* ((lexical-binding nil) + (f (native-compile '(lambda (x) (1+ x))))) + (should (subr-native-elisp-p f)) + (should (= (funcall f 2) 3)))) + +(comp-deftest comp-test-defsubst () + ;; Bug#42664, Bug#43280, Bug#44209. + (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f)))) + +(comp-deftest primitive-redefine-compile-44221 () + "Test the compiler still works while primitives are redefined (bug#44221)." + (cl-letf (((symbol-function #'delete-region) + (lambda (_ _)))) + (should (subr-native-elisp-p + (native-compile + '(lambda () + (delete-region (point-min) (point-max)))))))) + +(comp-deftest and-3 () + (should (= (comp-test-and-3-f t) 2)) + (should (null (comp-test-and-3-f '(1 2))))) + +(comp-deftest copy-insn () + (should (equal (comp-test-copy-insn-f '(1 2 3 (4 5 6))) + '(1 2 3 (4 5 6)))) + (should (null (comp-test-copy-insn-f nil)))) + +(comp-deftest cond-rw-1 () + "Check cond-rw does not break target blocks with multiple predecessor." + (should (null (comp-test-cond-rw-1-2-f)))) + +(comp-deftest not-cons-1 () + (should-not (comp-test-not-cons-f nil))) + +(comp-deftest 45576-1 () + "Functionp satisfies also symbols. +<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-01/msg00029.html>." + (should (eq (comp-test-45576-f) 'eval))) + +(comp-deftest 45635-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-01/msg00158.html>." + (should (string= (comp-test-45635-f :height 180 :family "PragmataPro Liga") + "PragmataPro Liga"))) + +(comp-deftest 45603-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01994.html>" + (load (native-compile (ert-resource-file "comp-test-45603.el"))) + (should (fboundp #'comp-test-45603--file-local-name))) + +(comp-deftest 46670-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01413.html>" + (should (string= (comp-test-46670-2-f "foo") "foo")) + (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) + '(function (t) t)))) + +(comp-deftest 46824-1 () + "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01949.html>" + (should (equal (comp-test-46824-1-f) nil))) + +(comp-deftest comp-test-47868-1 () + "Verify string hash consing strategy. + +<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-04/msg00921.html>" + (should-not (equal-including-properties (comp-test-47868-1-f) + (comp-test-47868-2-f))) + (should (eq (comp-test-47868-1-f) (comp-test-47868-3-f))) + (should (eq (comp-test-47868-2-f) (comp-test-47868-4-f)))) + + +;;;;;;;;;;;;;;;;;;;;; +;; Tromey's tests. ;; +;;;;;;;;;;;;;;;;;;;;; + +(comp-deftest consp () + (should-not (comp-test-consp 23)) + (should-not (comp-test-consp nil)) + (should (comp-test-consp '(1 . 2)))) + +(comp-deftest listp () + (should-not (comp-test-listp 23)) + (should (comp-test-listp nil)) + (should (comp-test-listp '(1 . 2)))) + +(comp-deftest stringp () + (should-not (comp-test-stringp 23)) + (should-not (comp-test-stringp nil)) + (should (comp-test-stringp "hi"))) + +(comp-deftest symbolp () + (should-not (comp-test-symbolp 23)) + (should-not (comp-test-symbolp "hi")) + (should (comp-test-symbolp 'whatever))) + +(comp-deftest integerp () + (should (comp-test-integerp 23)) + (should-not (comp-test-integerp 57.5)) + (should-not (comp-test-integerp "hi")) + (should-not (comp-test-integerp 'whatever))) + +(comp-deftest numberp () + (should (comp-test-numberp 23)) + (should (comp-test-numberp 57.5)) + (should-not (comp-test-numberp "hi")) + (should-not (comp-test-numberp 'whatever))) + +(comp-deftest add1 () + (should (eq (comp-test-add1 23) 24)) + (should (eq (comp-test-add1 -17) -16)) + (should (eql (comp-test-add1 1.0) 2.0)) + (should-error (comp-test-add1 nil) + :type 'wrong-type-argument)) + +(comp-deftest sub1 () + (should (eq (comp-test-sub1 23) 22)) + (should (eq (comp-test-sub1 -17) -18)) + (should (eql (comp-test-sub1 1.0) 0.0)) + (should-error (comp-test-sub1 nil) + :type 'wrong-type-argument)) + +(comp-deftest negate () + (should (eq (comp-test-negate 23) -23)) + (should (eq (comp-test-negate -17) 17)) + (should (eql (comp-test-negate 1.0) -1.0)) + (should-error (comp-test-negate nil) + :type 'wrong-type-argument)) + +(comp-deftest not () + (should (eq (comp-test-not 23) nil)) + (should (eq (comp-test-not nil) t)) + (should (eq (comp-test-not t) nil))) + +(comp-deftest bobp-and-eobp () + (with-temp-buffer + (should (comp-test-bobp)) + (should (comp-test-eobp)) + (insert "hi") + (goto-char (point-min)) + (should (eq (comp-test-point-min) (point-min))) + (should (eq (comp-test-point) (point-min))) + (should (comp-test-bobp)) + (should-not (comp-test-eobp)) + (goto-char (point-max)) + (should (eq (comp-test-point-max) (point-max))) + (should (eq (comp-test-point) (point-max))) + (should-not (comp-test-bobp)) + (should (comp-test-eobp)))) + +(comp-deftest car-cdr () + (let ((pair '(1 . b))) + (should (eq (comp-test-car pair) 1)) + (should (eq (comp-test-car nil) nil)) + (should-error (comp-test-car 23) + :type 'wrong-type-argument) + (should (eq (comp-test-cdr pair) 'b)) + (should (eq (comp-test-cdr nil) nil)) + (should-error (comp-test-cdr 23) + :type 'wrong-type-argument))) + +(comp-deftest car-cdr-safe () + (let ((pair '(1 . b))) + (should (eq (comp-test-car-safe pair) 1)) + (should (eq (comp-test-car-safe nil) nil)) + (should (eq (comp-test-car-safe 23) nil)) + (should (eq (comp-test-cdr-safe pair) 'b)) + (should (eq (comp-test-cdr-safe nil) nil)) + (should (eq (comp-test-cdr-safe 23) nil)))) + +(comp-deftest eq () + (should (comp-test-eq 'a 'a)) + (should (comp-test-eq 5 5)) + (should-not (comp-test-eq 'a 'b))) + +(comp-deftest if () + (should (eq (comp-test-if 'a 'b) 'a)) + (should (eq (comp-test-if 0 23) 0)) + (should (eq (comp-test-if nil 'b) 'b))) + +(comp-deftest and () + (should (eq (comp-test-and 'a 'b) 'b)) + (should (eq (comp-test-and 0 23) 23)) + (should (eq (comp-test-and nil 'b) nil))) + +(comp-deftest or () + (should (eq (comp-test-or 'a 'b) 'a)) + (should (eq (comp-test-or 0 23) 0)) + (should (eq (comp-test-or nil 'b) 'b))) + +(comp-deftest save-excursion () + (with-temp-buffer + (comp-test-save-excursion) + (should (eq (point) (point-min))) + (should (eq (comp-test-current-buffer) (current-buffer))))) + +(comp-deftest > () + (should (eq (comp-test-> 0 23) nil)) + (should (eq (comp-test-> 23 0) t))) + +(comp-deftest catch () + (should (eq (comp-test-catch 0 1 2 3 4) nil)) + (should (eq (comp-test-catch 20 21 22 23 24 25 26 27 28) 24))) + +(comp-deftest memq () + (should (equal (comp-test-memq 0 '(5 4 3 2 1 0)) '(0))) + (should (eq (comp-test-memq 72 '(5 4 3 2 1 0)) nil))) + +(comp-deftest listN () + (should (equal (comp-test-listN 57) + '(57 57 57 57 57 57 57 57 57 57 57 57 57 57 57 57)))) + +(comp-deftest concatN () + (should (equal (comp-test-concatN "x") "xxxxxx"))) + +(comp-deftest opt-rest () + (should (equal (comp-test-opt-rest 1) '(1 nil nil))) + (should (equal (comp-test-opt-rest 1 2) '(1 2 nil))) + (should (equal (comp-test-opt-rest 1 2 3) '(1 2 (3)))) + (should (equal (comp-test-opt-rest 1 2 56 57 58) + '(1 2 (56 57 58))))) + +(comp-deftest opt () + (should (equal (comp-test-opt 23) '(23))) + (should (equal (comp-test-opt 23 24) '(23 . 24))) + (should-error (comp-test-opt) + :type 'wrong-number-of-arguments) + (should-error (comp-test-opt nil 24 97) + :type 'wrong-number-of-arguments)) + +(comp-deftest unwind-protect () + (comp-test-unwind-protect 'ignore) + (should (eq comp-test-up-val 999)) + (condition-case nil + (comp-test-unwind-protect (lambda () (error "HI"))) + (error + nil)) + (should (eq comp-test-up-val 999))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Tests for dynamic scope. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(comp-deftest dynamic-ffuncall () + "Test calling convention for dynamic binding." + + (should (equal (comp-tests-ffuncall-callee-dyn-f 1 2) + '(1 2))) + + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3 4) + '(1 2 3 4))) + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-opt-dyn-f 1 2) + '(1 2 nil nil))) + + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2) + '(1 2 nil))) + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3) + '(1 2 (3)))) + (should (equal (comp-tests-ffuncall-callee-rest-dyn-f 1 2 3 4) + '(1 2 (3 4)))) + + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2) + '(1 2 nil nil))) + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3) + '(1 2 3 nil))) + (should (equal (comp-tests-ffuncall-callee-opt-rest-dyn-f 1 2 3 4) + '(1 2 3 (4))))) + +(comp-deftest dynamic-arity () + "Test func-arity on dynamic scope functions." + (should (equal '(2 . 2) + (func-arity #'comp-tests-ffuncall-callee-dyn-f))) + (should (equal '(2 . 4) + (func-arity #'comp-tests-ffuncall-callee-opt-dyn-f))) + (should (equal '(2 . many) + (func-arity #'comp-tests-ffuncall-callee-rest-dyn-f))) + (should (equal '(2 . many) + (func-arity #'comp-tests-ffuncall-callee-opt-rest-dyn-f)))) + +(comp-deftest dynamic-help-arglist () + "Test `help-function-arglist' works on lisp/d (bug#42572)." + (should (equal (help-function-arglist + (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) + t) + '(a b &optional c &rest d)))) + +(comp-deftest cl-macro-exp () + "Verify CL macro expansion (bug#42088)." + (should (equal (comp-tests-cl-macro-exp-f) '(a b)))) + +(comp-deftest cl-uninterned-arg-parse-f () + "Verify the parsing of a lambda list with uninterned symbols (bug#42120)." + (should (equal (comp-tests-cl-uninterned-arg-parse-f 1 2) + '(1 2)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Middle-end specific tests. ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun comp-tests-mentioned-p-1 (x insn) + (cl-loop for y in insn + when (cond + ((consp y) (comp-tests-mentioned-p x y)) + ((and (comp-mvar-p y) (comp-cstr-imm-vld-p y)) + (equal (comp-cstr-imm y) x)) + (t (equal x y))) + return t)) + +(defun comp-tests-mentioned-p (x insn) + "Check if X is actively mentioned in INSN." + (unless (eq (car-safe insn) + 'comment) + (comp-tests-mentioned-p-1 x insn))) + +(defun comp-tests-map-checker (func-name checker) + "Apply CHECKER to each insn of FUNC-NAME. +Return a list of results." + (cl-loop + with func-c-name = (comp-c-func-name (or func-name 'anonymous-lambda) "F" t) + with f = (gethash func-c-name (comp-ctxt-funcs-h comp-ctxt)) + for bb being each hash-value of (comp-func-blocks f) + nconc + (cl-loop + for insn in (comp-block-insns bb) + collect (funcall checker insn)))) + +(defun comp-tests-tco-checker (_) + "Check that inside `comp-tests-tco-f' we have no recursion." + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-tco-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-tco-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) + insn))))))) + +(comp-deftest tco () + "Check for tail recursion elimination." + (let ((native-comp-speed 3) + ;; Disable ipa-pure otherwise `comp-tests-tco-f' gets + ;; optimized-out. + (comp-disabled-passes '(comp-ipa-pure)) + (comp-post-pass-hooks '((comp-tco comp-tests-tco-checker) + (comp-final comp-tests-tco-checker)))) + (eval '(defun comp-tests-tco-f (a b count) + (if (= count 0) + b + (comp-tests-tco-f (+ a b) a (- count 1)))) + t) + (native-compile #'comp-tests-tco-f) + (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) + (should (= (comp-tests-tco-f 1 0 10) 55)))) + +(defun comp-tests-fw-prop-checker-1 (_) + "Check that inside `comp-tests-fw-prop-f' `concat' and `length' are folded." + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-fw-prop-1-f + (lambda (insn) + (or (comp-tests-mentioned-p 'concat insn) + (comp-tests-mentioned-p 'length insn))))))) + +(comp-deftest fw-prop-1 () + "Some tests for forward propagation." + (let ((native-comp-speed 2) + (comp-post-pass-hooks '((comp-final comp-tests-fw-prop-checker-1)))) + (eval '(defun comp-tests-fw-prop-1-f () + (let* ((a "xxx") + (b "yyy") + (c (concat a b))) ; <= has to optimize + (length c))) ; <= has to optimize + t) + (native-compile #'comp-tests-fw-prop-1-f) + (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) + (should (= (comp-tests-fw-prop-1-f) 6)))) + +(defun comp-tests-check-ret-type-spec (func-form ret-type) + (let ((lexical-binding t) + (native-comp-speed 2) + (f-name (cl-second func-form))) + (eval func-form t) + (native-compile f-name) + (should (equal (cl-third (subr-type (symbol-function f-name))) + ret-type)))) + +(cl-eval-when (compile eval load) + (defconst comp-tests-type-spec-tests + `( + ;; 1 + ((defun comp-tests-ret-type-spec-f (x) + x) + t) + + ;; 2 + ((defun comp-tests-ret-type-spec-f () + 1) + (integer 1 1)) + + ;; 3 + ((defun comp-tests-ret-type-spec-f (x) + (if x 1 3)) + (or (integer 1 1) (integer 3 3))) + + ;; 4 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (if x + (setf y 1) + (setf y 2)) + y)) + (integer 1 2)) + + ;; 5 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (if x + (setf y 1) + (setf y 3)) + y)) + (or (integer 1 1) (integer 3 3))) + + ;; 6 + ((defun comp-tests-ret-type-spec-f (x) + (if x + (list x) + 3)) + (or cons (integer 3 3))) + + ;; 7 + ((defun comp-tests-ret-type-spec-f (x) + (if x + 'foo + 3)) + (or (member foo) (integer 3 3))) + + ;; 8 + ((defun comp-tests-ret-type-spec-f (x) + (if (eq x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; 9 + ((defun comp-tests-ret-type-spec-f (x) + (if (eq 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; 10 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql x 3) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; 11 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql 3 x) + x + 'foo)) + (or (member foo) (integer 3 3))) + + ;; 12 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql x 3) + 'foo + x)) + (not (integer 3 3))) + + ;; 13 + ((defun comp-tests-ret-type-spec-f (x y) + (if (= x y) + x + 'foo)) + (or (member foo) marker number)) + + ;; 14 + ((defun comp-tests-ret-type-spec-f (x) + (comp-hint-fixnum x)) + (integer ,most-negative-fixnum ,most-positive-fixnum)) + + ;; 15 + ((defun comp-tests-ret-type-spec-f (x) + (comp-hint-cons x)) + cons) + + ;; 16 + ((defun comp-tests-ret-type-spec-f (x) + (let (y) + (when x + (setf y 4)) + y)) + (or null (integer 4 4))) + + ;; 17 + ((defun comp-tests-ret-type-spec-f () + (let (x + (y 3)) + (setf x y) + y)) + (integer 3 3)) + + ;; 18 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when x + (setf y x)) + y)) + t) + + ;; 19 + ((defun comp-tests-ret-type-spec-f (x y) + (eq x y)) + boolean) + + ;; 20 + ((defun comp-tests-ret-type-spec-f (x) + (when x + 'foo)) + (or (member foo) null)) + + ;; 21 + ((defun comp-tests-ret-type-spec-f (x) + (unless x + 'foo)) + (or (member foo) null)) + + ;; 22 + ((defun comp-tests-ret-type-spec-f (x) + (when (> x 3) + x)) + (or null float (integer 4 *))) + + ;; 23 + ((defun comp-tests-ret-type-spec-f (x) + (when (>= x 3) + x)) + (or null float (integer 3 *))) + + ;; 24 + ((defun comp-tests-ret-type-spec-f (x) + (when (< x 3) + x)) + (or null float (integer * 2))) + + ;; 25 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= x 3) + x)) + (or null float (integer * 3))) + + ;; 26 + ((defun comp-tests-ret-type-spec-f (x) + (when (> 3 x) + x)) + (or null float (integer * 2))) + + ;; 27 + ((defun comp-tests-ret-type-spec-f (x) + (when (>= 3 x) + x)) + (or null float (integer * 3))) + + ;; 28 + ((defun comp-tests-ret-type-spec-f (x) + (when (< 3 x) + x)) + (or null float (integer 4 *))) + + ;; 29 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 3 x) + x)) + (or null float (integer 3 *))) + + ;; 30 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when (> x y) + x))) + (or null float (integer 4 *))) + + ;; 31 + ((defun comp-tests-ret-type-spec-f (x) + (let ((y 3)) + (when (> y x) + x))) + (or null float (integer * 2))) + + ;; 32 + ((defun comp-tests-ret-type-spec-f (x) + (when (and (> x 3) + (< x 10)) + x)) + (or null float (integer 4 9))) + + ;; 33 + ((defun comp-tests-ret-type-spec-f (x) + (when (or (> x 3) + (< x 10)) + x)) + (or null float integer)) + + ;; 34 + ((defun comp-tests-ret-type-spec-f (x) + (when (or (< x 3) + (> x 10)) + x)) + (or null float (integer * 2) (integer 11 *))) + + ;; 35 No float range support. + ((defun comp-tests-ret-type-spec-f (x) + (when (> x 1.0) + x)) + (or null marker number)) + + ;; 36 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (> x 3) + (> y 2)) + (+ x y))) + (or null float (integer 7 *))) + + ;; 37 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 3) + (<= y 2)) + (+ x y))) + (or null float (integer * 5))) + + ;; 38 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (< 1 x 5) + (< 1 y 5)) + (+ x y))) + (or null float (integer 4 8))) + + ;; 39 + ;; SBCL gives: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (+ x y))) + (or null float (integer 3 13))) + + ;; 40 + ;; SBCL: (OR REAL NULL) + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y 3)) + (- x y))) + (or null float (integer -2 8))) + + ;; 41 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x) + (<= 2 y 3)) + (- x y))) + (or null float (integer -2 *))) + + ;; 42 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 1 x 10) + (<= 2 y)) + (- x y))) + (or null float (integer * 8))) + + ;; 43 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= 2 y)) + (- x y))) + (or null float (integer * 8))) + + ;; 44 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= x 10) + (<= y 3)) + (- x y))) + (or null float integer)) + + ;; 45 + ((defun comp-tests-ret-type-spec-f (x y) + (when (and (<= 2 x) + (<= 3 y)) + (- x y))) + (or null float integer)) + + ;; 46 + ;; SBCL: (OR (RATIONAL (6) (30)) (SINGLE-FLOAT 6.0 30.0) + ;; (DOUBLE-FLOAT 6.0d0 30.0d0) NULL) + ((defun comp-tests-ret-type-spec-f (x y z i j k) + (when (and (< 1 x 5) + (< 1 y 5) + (< 1 z 5) + (< 1 i 5) + (< 1 j 5) + (< 1 k 5)) + (+ x y z i j k))) + (or null float (integer 12 24))) + + ;; 47 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 1 x 5) + (1+ x))) + (or null float (integer 2 6))) + + ;;48 + ((defun comp-tests-ret-type-spec-f (x) + (when (<= 1 x 5) + (1- x))) + (or null float (integer 0 4))) + + ;; 49 + ((defun comp-tests-ret-type-spec-f () + (error "foo")) + nil) + + ;; 50 + ((defun comp-tests-ret-type-spec-f (x) + (if (stringp x) + x + 'bar)) + (or (member bar) string)) + + ;; 51 + ((defun comp-tests-ret-type-spec-f (x) + (if (stringp x) + 'bar + x)) + (not string)) + + ;; 52 + ((defun comp-tests-ret-type-spec-f (x) + (if (integerp x) + x + 'bar)) + (or (member bar) integer)) + + ;; 53 + ((defun comp-tests-ret-type-spec-f (x) + (when (integerp x) + x)) + (or null integer)) + + ;; 54 + ((defun comp-tests-ret-type-spec-f (x) + (unless (symbolp x) + x)) + t) + + ;; 55 + ((defun comp-tests-ret-type-spec-f (x) + (unless (integerp x) + x)) + (not integer)) + + ;; 56 + ((defun comp-tests-ret-type-spec-f (x) + (cl-ecase x + (1 (message "one")) + (5 (message "five"))) + x) + t + ;; FIXME improve `comp-cond-cstrs-target-mvar' to cross block + ;; boundary if necessary as this should return: + ;; (or (integer 1 1) (integer 5 5)) + ) + + ;; 57 + ((defun comp-tests-ret-type-spec-f (x) + (unless (or (eq x 'foo) + (eql x 3)) + (error "Not foo or 3")) + x) + (or (member foo) (integer 3 3))) + + ;;58 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (natnump x) + (natnump y) + (<= x y)) + x + (error ""))) + (integer 0 *)) + + ;; 59 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (>= x 3) + (<= y 10) + (<= x y)) + x + (error ""))) + (or float (integer 3 10))) + + ;; 60 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (<= x 10) + (>= y 3) + (>= x y)) + x + (error ""))) + (or float (integer 3 10))) + + ;; 61 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 62 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.0) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 63 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1.1) + x + (error ""))) + (member 1.1)) + + ;; 64 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 65 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 1) + x + (error ""))) + (or (member 1.0) (integer 1 1))) + + ;; 66 + ((defun comp-tests-ret-type-spec-f (x) + (if (eql x 0.0) + x + (error ""))) + float) + + ;; 67 + ((defun comp-tests-ret-type-spec-f (x) + (if (equal x '(1 2 3)) + x + (error ""))) + cons) + + ;; 68 + ((defun comp-tests-ret-type-spec-f (x) + (if (and (floatp x) + (= x 1)) + x + (error ""))) + ;; Conservative (see cstr relax in `comp-cstr-='). + (or (member 1.0) (integer 1 1))) + + ;; 69 + ((defun comp-tests-ret-type-spec-f (x) + (if (and (integer x) + (= x 1)) + x + (error ""))) + ;; Conservative (see cstr relax in `comp-cstr-='). + (or (member 1.0) (integer 1 1))) + + ;; 70 + ((defun comp-tests-ret-type-spec-f (x y) + (if (and (floatp x) + (integerp y) + (= x y)) + x + (error ""))) + (or float integer)) + + ;; 71 + ((defun comp-tests-ret-type-spec-f (x) + (if (= x 0.0) + x + (error ""))) + (or (member -0.0 0.0) (integer 0 0))) + + ;; 72 + ((defun comp-tests-ret-type-spec-f (x) + (unless (= x 0.0) + (error "")) + (unless (eql x -0.0) + (error "")) + x) + float) + + ;; 73 + ((defun comp-tests-ret-type-spec-f (x) + (when (eql x 1.0) + (error "")) + x) + t))) + + (defun comp-tests-define-type-spec-test (number x) + `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) () + ,(format "Type specifier test number %d." number) + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-tests-check-ret-type-spec ',(car x) ',(cadr x)))))) + +(defmacro comp-tests-define-type-spec-tests () + "Define all type specifier tests." + `(progn + ,@(cl-loop + for test in comp-tests-type-spec-tests + for n from 1 + collect (comp-tests-define-type-spec-test n test)))) + +(comp-tests-define-type-spec-tests) + +(defun comp-tests-pure-checker-1 (_) + "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is + folded." + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-pure-caller-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-callee-f insn) + (comp-tests-mentioned-p (comp-c-func-name + 'comp-tests-pure-callee-f "F" t) + insn))))))) + +(defun comp-tests-pure-checker-2 (_) + "Check that `comp-tests-pure-fibn-f' is folded." + (should + (cl-notany + #'identity + (comp-tests-map-checker + 'comp-tests-pure-fibn-entry-f + (lambda (insn) + (or (comp-tests-mentioned-p 'comp-tests-pure-fibn-f insn) + (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-pure-fibn-f "F" t) + insn))))))) + +(comp-deftest pure () + "Some tests for pure functions optimization." + (let ((native-comp-speed 3) + (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 + comp-tests-pure-checker-2)))) + (load (native-compile (ert-resource-file "comp-test-pure.el"))) + + (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f))) + (should (= (comp-tests-pure-caller-f) 4)) + + (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f))) + (should (= (comp-tests-pure-fibn-entry-f) 6765)))) + +(defvar comp-tests-cond-rw-checked-function nil + "Function to be checked.") +(defun comp-tests-cond-rw-checker-val (_) + "Check we manage to propagate the correct return value." + (should + (cl-some + #'identity + (comp-tests-map-checker + comp-tests-cond-rw-checked-function + (lambda (insn) + (pcase insn + (`(return ,mvar) + (and (comp-cstr-imm-vld-p mvar) + (eql (comp-cstr-imm mvar) 123))))))))) + +(defvar comp-tests-cond-rw-expected-type nil + "Type to expect in `comp-tests-cond-rw-checker-type'.") +(defun comp-tests-cond-rw-checker-type (_) + "Check we manage to propagate the correct return type." + (should + (cl-some + #'identity + (comp-tests-map-checker + comp-tests-cond-rw-checked-function + (lambda (insn) + (pcase insn + (`(return ,mvar) + (equal (comp-mvar-typeset mvar) + comp-tests-cond-rw-expected-type)))))))) + +;;; comp-tests.el ends here diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 03d867f18a8..b1e5fa0767c 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -358,12 +358,35 @@ comparing the subr with a much slower lisp implementation." (should (equal (symbol-value var) 42)) (should (equal (default-value var) (symbol-value var))) (set var 123) + (should (not (local-variable-p var))) (should (equal (symbol-value var) 123)) (should (equal (default-value var) (symbol-value var)))) ;bug#44733 (should (equal (symbol-value var) def)) (should (equal (default-value var) (symbol-value var)))) (should (equal (default-value var) def)))))) +(ert-deftest data-tests--let-buffer-local-no-unwind-other-buffers () + "Test that a let-binding for a buffer-local unwinds only current-buffer." + (let ((blvar (make-symbol "blvar"))) + (set-default blvar 0) + (make-variable-buffer-local blvar) + (dolist (var (list blvar 'left-margin)) + (let* ((def (default-value var)) + (newdef (+ def 1)) + (otherbuf (generate-new-buffer "otherbuf"))) + (with-temp-buffer + (cl-progv (list var) (list newdef) + (with-current-buffer otherbuf + (set var 123) + (should (local-variable-p var)) + (should (equal (symbol-value var) 123)) + (should (equal (default-value var) newdef)))) + (with-current-buffer otherbuf + (should (local-variable-p var)) + (should (equal (symbol-value var) 123)) + (should (equal (default-value var) def))) + ))))) + (ert-deftest binding-test-makunbound () "Tests of makunbound, from the manual." (with-current-buffer binding-test-buffer-B diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index dcec971c12e..a731a95ccf0 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -1,4 +1,4 @@ -;;; editfns-tests.el -- tests for editfns.c -*- lexical-binding:t -*- +;;; editfns-tests.el --- tests for editfns.c -*- lexical-binding:t -*- ;; Copyright (C) 2016-2021 Free Software Foundation, Inc. @@ -128,6 +128,10 @@ (format (concat "%-3d/" s) 12) #("12 /X" 4 5 (prop "val")))))) +(ert-deftest propertize/error-even-number-of-args () + "Number of args for `propertize' must be odd." + (should-error (propertize "foo" 'bar) :type 'wrong-number-of-arguments)) + ;; Tests for bug#5131. (defun transpose-test-reverse-word (start end) "Reverse characters in a word by transposing pairs of characters." diff --git a/test/src/emacs-module-resources/mod-test.c b/test/src/emacs-module-resources/mod-test.c index ad59cfc18cd..5720af8c605 100644 --- a/test/src/emacs-module-resources/mod-test.c +++ b/test/src/emacs-module-resources/mod-test.c @@ -288,6 +288,8 @@ struct super_struct char large_unused_buffer[512]; }; +static void signal_errno (emacs_env *, char const *); + /* Return a new user-pointer to a super_struct, with amazing_int set to the passed parameter. */ static emacs_value @@ -295,6 +297,8 @@ Fmod_test_userptr_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[], void *data) { struct super_struct *p = calloc (1, sizeof *p); + if (!p) + signal_errno (env, "calloc"); p->amazing_int = env->extract_integer (env, args[0]); return env->make_user_ptr (env, free, p); } diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index af5bc2a0baf..a4d858113ed 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -1,4 +1,4 @@ -;;; emacs-module-tests --- Test GNU Emacs modules. -*- lexical-binding: t; -*- +;;; emacs-module-tests.el --- Test GNU Emacs modules. -*- lexical-binding: t; -*- ;; Copyright 2015-2021 Free Software Foundation, Inc. @@ -37,7 +37,9 @@ "File name of the Emacs binary currently running.") (eval-and-compile - (defconst mod-test-file (ert-resource-file "mod-test") + (defconst mod-test-file + (expand-file-name "../test/src/emacs-module-resources/mod-test" + invocation-directory) "File name of the module test file.")) (require 'mod-test mod-test-file) diff --git a/test/src/emacs-tests.el b/test/src/emacs-tests.el new file mode 100644 index 00000000000..ac08e055b55 --- /dev/null +++ b/test/src/emacs-tests.el @@ -0,0 +1,263 @@ +;;; emacs-tests.el --- unit tests for emacs.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-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/>. + +;;; Commentary: + +;; Unit tests for src/emacs.c. + +;;; Code: + +(require 'cl-lib) +(require 'ert) +(require 'rx) +(require 'subr-x) + +(defconst emacs-tests--lib-src + (substitute-in-file-name "$EMACS_TEST_DIRECTORY/../lib-src/") + "Location of the lib-src directory.") + +(ert-deftest emacs-tests/seccomp/absent-file () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (should-not (file-exists-p "/does-not-exist.bpf")) + (should-not + (eql (call-process emacs nil nil nil + "--quick" "--batch" + "--seccomp=/does-not-exist.bpf") + 0)))) + +(cl-defmacro emacs-tests--with-temp-file + (var (prefix &optional suffix text) &rest body) + "Evaluate BODY while a new temporary file exists. +Bind VAR to the name of the file. Pass PREFIX, SUFFIX, and TEXT +to `make-temp-file', which see." + (declare (indent 2) (debug (symbolp (form form form) body))) + (cl-check-type var symbol) + ;; Use an uninterned symbol so that the code still works if BODY + ;; changes VAR. + (let ((filename (make-symbol "filename"))) + `(let ((,filename (make-temp-file ,prefix nil ,suffix ,text))) + (unwind-protect + (let ((,var ,filename)) + ,@body) + (delete-file ,filename))))) + +(ert-deftest emacs-tests/seccomp/empty-file () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf") + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't + ;; work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + ;; According to the Seccomp man page, a filter must have at + ;; least one element, so Emacs should reject an empty file. + (should-not + (eql (call-process emacs nil nil nil + "--quick" "--batch" + (concat "--seccomp=" filter)) + 0))))) + +(ert-deftest emacs-tests/seccomp/file-too-large () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (process-environment nil) + ;; This value should be correct on all supported systems. + (ushort-max #xFFFF) + ;; Either 8 or 16, but 16 should be large enough in all cases. + (filter-size 16)) + (skip-unless (file-executable-p emacs)) + (emacs-tests--with-temp-file + filter ("seccomp-too-large-" ".bpf" + (make-string (* (1+ ushort-max) filter-size) ?a)) + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't + ;; work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + ;; The filter count must fit into an `unsigned short'. A bigger + ;; file should be rejected. + (should-not + (eql (call-process emacs nil nil nil + "--quick" "--batch" + (concat "--seccomp=" filter)) + 0))))) + +(ert-deftest emacs-tests/seccomp/invalid-file-size () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf" + "123456") + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't + ;; work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + ;; The Seccomp filter file must have a file size that's a + ;; multiple of the size of struct sock_filter, which is 8 or 16, + ;; but never 6. + (should-not + (eql (call-process emacs nil nil nil + "--quick" "--batch" + (concat "--seccomp=" filter)) + 0))))) + +(ert-deftest emacs-tests/seccomp/allows-stdout () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (filter (expand-file-name "seccomp-filter.bpf" + emacs-tests--lib-src)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (skip-unless (file-readable-p filter)) + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + (with-temp-buffer + (let ((start-time (current-time)) + (status (call-process + emacs nil t nil + "--quick" "--batch" + (concat "--seccomp=" filter) + (format "--eval=%S" '(message "Hi")))) + (end-time (current-time))) + (ert-info ((emacs-tests--seccomp-debug start-time end-time)) + (should (eql status 0))) + (should (equal (string-trim (buffer-string)) "Hi")))))) + +(ert-deftest emacs-tests/seccomp/forbids-subprocess () + (skip-unless (string-match-p (rx bow "SECCOMP" eow) + system-configuration-features)) + (let ((emacs + (expand-file-name invocation-name invocation-directory)) + (filter (expand-file-name "seccomp-filter.bpf" + emacs-tests--lib-src)) + (process-environment nil)) + (skip-unless (file-executable-p emacs)) + (skip-unless (file-readable-p filter)) + ;; The --seccomp option is processed early, without filename + ;; handlers. Therefore remote or quoted filenames wouldn't work. + (should-not (file-remote-p filter)) + (cl-callf file-name-unquote filter) + (with-temp-buffer + (let ((start-time (current-time)) + (status + (call-process + emacs nil t nil + "--quick" "--batch" + (concat "--seccomp=" filter) + (format "--eval=%S" `(call-process ,emacs nil nil nil + "--version")))) + (end-time (current-time))) + (ert-info ((emacs-tests--seccomp-debug start-time end-time)) + (should-not (eql status 0))))))) + +(ert-deftest emacs-tests/bwrap/allows-stdout () + (let ((bash (executable-find "bash")) + (bwrap (executable-find "bwrap")) + (emacs + (expand-file-name invocation-name invocation-directory)) + (filter (expand-file-name "seccomp-filter-exec.bpf" + emacs-tests--lib-src)) + (process-environment nil)) + (skip-unless bash) + (skip-unless bwrap) + (skip-unless (file-executable-p emacs)) + (skip-unless (file-readable-p filter)) + (should-not (file-remote-p bwrap)) + (should-not (file-remote-p emacs)) + (should-not (file-remote-p filter)) + (with-temp-buffer + (let* ((command + (concat + (mapconcat #'shell-quote-argument + `(,(file-name-unquote bwrap) + "--ro-bind" "/" "/" + "--seccomp" "20" + "--" + ,(file-name-unquote emacs) + "--quick" "--batch" + ,(format "--eval=%S" '(message "Hi"))) + " ") + " 20< " + (shell-quote-argument (file-name-unquote filter)))) + (start-time (current-time)) + (status (call-process bash nil t nil "-c" command)) + (end-time (current-time))) + (ert-info ((emacs-tests--seccomp-debug start-time end-time)) + (should (eql status 0))) + (should (equal (string-trim (buffer-string)) "Hi")))))) + +(defun emacs-tests--seccomp-debug (start-time end-time) + "Return potentially useful debugging information for Seccomp. +Assume that the current buffer contains subprocess output for the +failing process. START-TIME and END-TIME are time values between +which the process was running." + ;; Add a bit of slack for the timestamps. + (cl-callf time-subtract start-time 5) + (cl-callf time-add end-time 5) + (with-output-to-string + (princ "Process output:") + (terpri) + (princ (buffer-substring-no-properties (point-min) (point-max))) + ;; Search audit logs for Seccomp messages. + (when-let ((ausearch (executable-find "ausearch"))) + (terpri) + (princ "Potentially relevant Seccomp audit events:") + (terpri) + (let ((process-environment '("LC_TIME=C"))) + (call-process ausearch nil standard-output nil + "--message" "SECCOMP" + "--start" + (format-time-string "%D" start-time) + (format-time-string "%T" start-time) + "--end" + (format-time-string "%D" end-time) + (format-time-string "%T" end-time) + "--interpret"))) + ;; Print coredump information if available. + (when-let ((coredumpctl (executable-find "coredumpctl"))) + (terpri) + (princ "Potentially useful coredump information:") + (terpri) + (call-process coredumpctl nil standard-output nil + "info" + "--since" (format-time-string "%F %T" start-time) + "--until" (format-time-string "%F %T" end-time) + "--no-pager")))) + +;;; emacs-tests.el ends here diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el index 7f193d4eeab..f4d123b4261 100644 --- a/test/src/fileio-tests.el +++ b/test/src/fileio-tests.el @@ -1,4 +1,4 @@ -;;; unit tests for src/fileio.c -*- lexical-binding: t; -*- +;;; fileio-tests.el --- unit tests for src/fileio.c -*- lexical-binding: t; -*- ;; Copyright 2017-2021 Free Software Foundation, Inc. @@ -160,4 +160,26 @@ Also check that an encoding error can appear in a symlink." (should-error (file-exists-p "/foo\0bar") :type 'wrong-type-argument)) +(ert-deftest fileio-tests/file-name-concat () + (should (equal (file-name-concat "foo" "bar") "foo/bar")) + (should (equal (file-name-concat "foo" "bar") "foo/bar")) + (should (equal (file-name-concat "foo" "bar" "zot") "foo/bar/zot")) + (should (equal (file-name-concat "foo/" "bar") "foo/bar")) + (should (equal (file-name-concat "foo//" "bar") "foo//bar")) + (should (equal (file-name-concat "foo/" "bar/" "zot") "foo/bar/zot")) + (should (equal (file-name-concat "fóo" "bar") "fóo/bar")) + (should (equal (file-name-concat "foo" "bár") "foo/bár")) + (should (equal (file-name-concat "fóo" "bár") "fóo/bár")) + (let ((string (make-string 5 ?a))) + (should (not (multibyte-string-p string))) + (aset string 2 255) + (should (not (multibyte-string-p string))) + (should (equal (file-name-concat "fóo" string) "fóo/aa\377aa"))) + (should (equal (file-name-concat "foo") "foo")) + (should (equal (file-name-concat "foo/") "foo/")) + (should (equal (file-name-concat "foo" "") "foo")) + (should (equal (file-name-concat "foo" "" "" "" nil) "foo")) + (should (equal (file-name-concat "" "bar") "bar")) + (should (equal (file-name-concat "" "") ""))) + ;;; fileio-tests.el ends here diff --git a/test/src/filelock-tests.el b/test/src/filelock-tests.el new file mode 100644 index 00000000000..a96d6d67289 --- /dev/null +++ b/test/src/filelock-tests.el @@ -0,0 +1,183 @@ +;;; filelock-tests.el --- test file locking -*- 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file tests code in src/filelock.c and, to some extent, the +;; related code in src/fileio.c. +;; +;; See also (info "(emacs)Interlocking") and (info "(elisp)File Locks") + +;;; Code: + +(require 'cl-macs) +(require 'ert) +(require 'seq) + +(defun filelock-tests--fixture (test-function) + "Call TEST-FUNCTION under a test fixture. +Create a test directory and a buffer whose `buffer-file-name' and +`buffer-file-truename' are a file within it, then call +TEST-FUNCTION. Finally, delete the buffer and the test +directory." + (let* ((temp-dir (make-temp-file "filelock-tests" t)) + (name (concat (file-name-as-directory temp-dir) + "userfile")) + (create-lockfiles t)) + (unwind-protect + (with-temp-buffer + (setq buffer-file-name name + buffer-file-truename name) + (unwind-protect + (save-current-buffer + (funcall test-function)) + ;; Set `buffer-file-truename' nil to prevent unlocking, + ;; which might prompt the user and/or signal errors. + (setq buffer-file-name nil + buffer-file-truename nil))) + (delete-directory temp-dir t nil)))) + +(defun filelock-tests--make-lock-name (file-name) + "Return the lock file name for FILE-NAME. +Equivalent logic in Emacs proper is implemented in C and +unavailable to Lisp." + (concat (file-name-directory (expand-file-name file-name)) + ".#" + (file-name-nondirectory file-name))) + +(defun filelock-tests--spoil-lock-file (file-name) + "Spoil the lock file for FILE-NAME. +Cause Emacs to report errors for various file locking operations +on FILE-NAME going forward. Create a file that is incompatible +with Emacs' file locking protocol, but uses the same name as +FILE-NAME's lock file. A directory file is used, which is +portable in practice." + (make-directory (filelock-tests--make-lock-name file-name))) + +(defun filelock-tests--unspoil-lock-file (file-name) + "Remove the lock file spoiler for FILE-NAME. +See `filelock-tests--spoil-lock-file'." + (delete-directory (filelock-tests--make-lock-name file-name) t)) + +(defun filelock-tests--should-be-locked () + "Abort the current test if the current buffer is not locked. +Exception: on systems without lock file support, aborts the +current test if the current file is locked (which should never +the case)." + (if (eq system-type 'ms-dos) + (should-not (file-locked-p buffer-file-truename)) + (should (file-locked-p buffer-file-truename)))) + +(ert-deftest filelock-tests-lock-unlock-no-errors () + "Check that locking and unlocking works without error." + (filelock-tests--fixture + (lambda () + (should-not (file-locked-p (buffer-file-name))) + + ;; inserting text should lock the buffer's file. + (insert "this locks the buffer's file") + (filelock-tests--should-be-locked) + (unlock-buffer) + (set-buffer-modified-p nil) + (should-not (file-locked-p (buffer-file-name))) + + ;; `set-buffer-modified-p' should lock the buffer's file. + (set-buffer-modified-p t) + (filelock-tests--should-be-locked) + (unlock-buffer) + (should-not (file-locked-p (buffer-file-name))) + + (should-not (file-locked-p (buffer-file-name)))))) + +(ert-deftest filelock-tests-lock-spoiled () + "Check `lock-buffer' ." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (filelock-tests--fixture + (lambda () + (filelock-tests--spoil-lock-file buffer-file-truename) + ;; FIXME: errors when locking a file are ignored; should they be? + (set-buffer-modified-p t) + (filelock-tests--unspoil-lock-file buffer-file-truename) + (should-not (file-locked-p buffer-file-truename))))) + +(ert-deftest filelock-tests-file-locked-p-spoiled () + "Check that `file-locked-p' fails if the lockfile is \"spoiled\"." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (filelock-tests--fixture + (lambda () + (filelock-tests--spoil-lock-file buffer-file-truename) + (let ((err (should-error (file-locked-p (buffer-file-name))))) + (should (equal (seq-subseq err 0 2) + '(file-error "Testing file lock"))))))) + +(ert-deftest filelock-tests-unlock-spoiled () + "Check that `unlock-buffer' fails if the lockfile is \"spoiled\"." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (filelock-tests--fixture + (lambda () + ;; Set the buffer modified with file locking temporarily + ;; disabled. + (let ((create-lockfiles nil)) + (set-buffer-modified-p t)) + (should-not (file-locked-p buffer-file-truename)) + (filelock-tests--spoil-lock-file buffer-file-truename) + + ;; Errors from `unlock-buffer' should call + ;; `userlock--handle-unlock-error' (bug#46397). + (let (errors) + (cl-letf (((symbol-function 'userlock--handle-unlock-error) + (lambda (err) (push err errors)))) + (unlock-buffer)) + (should (consp errors)) + (should (equal '(file-error "Unlocking file") + (seq-subseq (car errors) 0 2))) + (should (equal (length errors) 1)))))) + +(ert-deftest filelock-tests-kill-buffer-spoiled () + "Check that `kill-buffer' fails if a lockfile is \"spoiled\"." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (filelock-tests--fixture + (lambda () + ;; Set the buffer modified with file locking temporarily + ;; disabled. + (let ((create-lockfiles nil)) + (set-buffer-modified-p t)) + (should-not (file-locked-p buffer-file-truename)) + (filelock-tests--spoil-lock-file buffer-file-truename) + + ;; Kill the current buffer. Because the buffer is modified Emacs + ;; will attempt to unlock it. Temporarily bind `yes-or-no-p' to + ;; a function that fakes a "yes" answer for the "Buffer modified; + ;; kill anyway?" prompt. + ;; + ;; File errors from unlocking files should call + ;; `userlock--handle-unlock-error' (bug#46397). + (let (errors) + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (&rest _) t)) + ((symbol-function 'userlock--handle-unlock-error) + (lambda (err) (push err errors)))) + (kill-buffer)) + (should (consp errors)) + (should (equal '(file-error "Unlocking file") + (seq-subseq (car errors) 0 2))) + (should (equal (length errors) 1)))))) + +(provide 'filelock-tests) +;;; filelock-tests.el ends here diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 928fb15f109..9f6593a177c 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-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/src/font-tests.el b/test/src/font-tests.el index de153b8de9b..ea57b122f4f 100644 --- a/test/src/font-tests.el +++ b/test/src/font-tests.el @@ -159,6 +159,31 @@ expected font properties from parsing NAME.") (insert "\n")))) (goto-char (point-min))) +(ert-deftest font-parse-xlfd-test () + ;; Normal number of segments. + (should (equal (font-get + (font-spec :name "-GNU -FreeSans-semibold-italic-normal-*-*-*-*-*-*-0-iso10646-1") + :family) + 'FreeSans)) + (should (equal (font-get + (font-spec :name "-GNU -FreeSans-semibold-italic-normal-*-*-*-*-*-*-0-iso10646-1") + :foundry) + 'GNU\ )) + ;; Dash in the family name. + (should (equal (font-get + (font-spec :name "-Take-mikachan-PS-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1") + :family) + 'mikachan-PS)) + (should (equal (font-get + (font-spec :name "-Take-mikachan-PS-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1") + :weight) + 'normal)) + ;; Synthetic test. + (should (equal (font-get + (font-spec :name "-foundry-name-with-lots-of-dashes-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1") + :family) + 'name-with-lots-of-dashes))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/src/indent-tests.el b/test/src/indent-tests.el index 10f1202949b..6a3f1a5c95f 100644 --- a/test/src/indent-tests.el +++ b/test/src/indent-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/src/json-tests.el b/test/src/json-tests.el index 4be11b8c81a..8dc0a744aa0 100644 --- a/test/src/json-tests.el +++ b/test/src/json-tests.el @@ -51,6 +51,34 @@ (should (equal (json-parse-buffer) lisp)) (should (eobp))))) +(ert-deftest json-serialize/roundtrip-scalars () + "Check that Bug#42994 is fixed." + (skip-unless (fboundp 'json-serialize)) + (dolist (case '((:null "null") + (:false "false") + (t "true") + (0 "0") + (123 "123") + (-456 "-456") + (3.75 "3.75") + ;; The noncharacter U+FFFF should be passed through, + ;; cf. https://www.unicode.org/faq/private_use.html#noncharacters. + ("abc\uFFFFαβγ𝔸𝐁𝖢\"\\" + "\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\""))) + (cl-destructuring-bind (lisp json) case + (ert-info ((format "%S ↔ %S" lisp json)) + (should (equal (json-serialize lisp) json)) + (with-temp-buffer + (json-insert lisp) + (should (equal (buffer-string) json)) + (should (eobp))) + (should (equal (json-parse-string json) lisp)) + (with-temp-buffer + (insert json) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) + (should (eobp))))))) + (ert-deftest json-serialize/object () (skip-unless (fboundp 'json-serialize)) (let ((table (make-hash-table :test #'equal))) @@ -224,7 +252,7 @@ Test with both unibyte and multibyte strings." (let* ((input "{ \"abc\" : [9, false] , \"def\" : null }") (output - (replace-regexp-in-string " " "" input))) + (string-replace " " "" input))) (should (equal (json-parse-string input :object-type 'plist :null-object :json-null diff --git a/test/src/keyboard-tests.el b/test/src/keyboard-tests.el index 607d2eafd45..41c8cdd15f0 100644 --- a/test/src/keyboard-tests.el +++ b/test/src/keyboard-tests.el @@ -23,14 +23,15 @@ (ert-deftest keyboard-unread-command-events () "Test `unread-command-events'." - (should (equal (progn (push ?\C-a unread-command-events) - (read-event nil nil 1)) - ?\C-a)) - (should (equal (progn (run-with-timer - 1 nil - (lambda () (push '(t . ?\C-b) unread-command-events))) - (read-event nil nil 2)) - ?\C-b))) + (let ((unread-command-events nil)) + (should (equal (progn (push ?\C-a unread-command-events) + (read-event nil nil 1)) + ?\C-a)) + (should (equal (progn (run-with-timer + 1 nil + (lambda () (push '(t . ?\C-b) unread-command-events))) + (read-event nil nil 2)) + ?\C-b)))) (ert-deftest keyboard-lossage-size () "Test `lossage-size'." @@ -46,6 +47,28 @@ (should-error (lossage-size (1- min-value))) (should (= lossage-orig (lossage-size lossage-orig))))) +;; FIXME: This test doesn't currently work :-( +;; (ert-deftest keyboard-tests--echo-keystrokes-bug15332 () +;; (let ((msgs '()) +;; (unread-command-events nil) +;; (redisplay--interactive t) +;; (echo-keystrokes 2)) +;; (setq unread-command-events '(?\C-u)) +;; (let* ((timer1 +;; (run-with-timer 3 1 +;; (lambda () +;; (setq unread-command-events '(?5))))) +;; (timer2 +;; (run-with-timer 2.5 1 +;; (lambda () +;; (push (current-message) msgs))))) +;; (run-with-timer 5 nil +;; (lambda () +;; (cancel-timer timer1) +;; (cancel-timer timer2) +;; (throw 'exit msgs))) +;; (recursive-edit) +;; (should (equal msgs '("C-u 55-" "C-u 5-" "C-u-")))))) (provide 'keyboard-tests) ;;; keyboard-tests.el ends here diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index d4f5fc3f190..a9b0cb502d3 100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@ -63,10 +63,66 @@ (keymap--get-keyelt object t) (should menu-item-filter-ran))) +(ert-deftest keymap-define-key/undefined () + ;; nil (means key is undefined in this keymap), + (let ((map (make-keymap))) + (define-key map [?a] nil) + (should-not (lookup-key map [?a])))) + +(ert-deftest keymap-define-key/keyboard-macro () + ;; a string (treated as a keyboard macro), + (let ((map (make-keymap))) + (define-key map [?a] "abc") + (should (equal (lookup-key map [?a]) "abc")))) + +(ert-deftest keymap-define-key/lambda () + (let ((map (make-keymap))) + (define-key map [?a] (lambda () (interactive) nil)) + (should (functionp (lookup-key map [?a]))))) + +(ert-deftest keymap-define-key/keymap () + ;; a keymap (to define a prefix key), + (let ((map (make-keymap)) + (map2 (make-keymap))) + (define-key map [?a] map2) + (define-key map2 [?b] 'foo) + (should (eq (lookup-key map [?a ?b]) 'foo)))) + +(ert-deftest keymap-define-key/menu-item () + ;; or an extended menu item definition. + ;; (See info node ‘(elisp)Extended Menu Items’.) + (let ((map (make-sparse-keymap)) + (menu (make-sparse-keymap))) + (define-key menu [new-file] + '(menu-item "Visit New File..." find-file + :enable (menu-bar-non-minibuffer-window-p) + :help "Specify a new file's name, to edit the file")) + (define-key map [menu-bar file] (cons "File" menu)) + (should (eq (lookup-key map [menu-bar file new-file]) 'find-file)))) + (ert-deftest keymap-lookup-key () (let ((map (make-keymap))) (define-key map [?a] 'foo) - (should (eq (lookup-key map [?a]) 'foo)))) + (should (eq (lookup-key map [?a]) 'foo)) + (should-not (lookup-key map [?b])))) + +(ert-deftest keymap-lookup-key/list-of-keymaps () + (let ((map1 (make-keymap)) + (map2 (make-keymap))) + (define-key map1 [?a] 'foo) + (define-key map2 [?b] 'bar) + (should (eq (lookup-key (list map1 map2) [?a]) 'foo)) + (should (eq (lookup-key (list map1 map2) [?b]) 'bar)) + (should-not (lookup-key (list map1 map2) [?c])))) + +(ert-deftest keymap-lookup-key/too-long () + (let ((map (make-keymap))) + (define-key map (kbd "C-c f") 'foo) + (should (= (lookup-key map (kbd "C-c f x")) 2)))) + +;; TODO: Write test for the ACCEPT-DEFAULT argument. +;; (ert-deftest keymap-lookup-key/accept-default () +;; ...) (ert-deftest describe-buffer-bindings/header-in-current-buffer () "Header should be inserted into the current buffer. diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index f2a60bcf327..dac8f95bc4d 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -196,4 +196,71 @@ literals (Bug#20852)." (should-error (read-event "foo: ")) (should-error (read-char-exclusive "foo: ")))) +(ert-deftest lread-float () + (should (equal (read "13") 13)) + (should (equal (read "+13") 13)) + (should (equal (read "-13") -13)) + (should (equal (read "13.") 13)) + (should (equal (read "+13.") 13)) + (should (equal (read "-13.") -13)) + (should (equal (read "13.25") 13.25)) + (should (equal (read "+13.25") 13.25)) + (should (equal (read "-13.25") -13.25)) + (should (equal (read ".25") 0.25)) + (should (equal (read "+.25") 0.25)) + (should (equal (read "-.25") -0.25)) + (should (equal (read "13e4") 130000.0)) + (should (equal (read "+13e4") 130000.0)) + (should (equal (read "-13e4") -130000.0)) + (should (equal (read "13e+4") 130000.0)) + (should (equal (read "+13e+4") 130000.0)) + (should (equal (read "-13e+4") -130000.0)) + (should (equal (read "625e-4") 0.0625)) + (should (equal (read "+625e-4") 0.0625)) + (should (equal (read "-625e-4") -0.0625)) + (should (equal (read "1.25e2") 125.0)) + (should (equal (read "+1.25e2") 125.0)) + (should (equal (read "-1.25e2") -125.0)) + (should (equal (read "1.25e+2") 125.0)) + (should (equal (read "+1.25e+2") 125.0)) + (should (equal (read "-1.25e+2") -125.0)) + (should (equal (read "1.25e-1") 0.125)) + (should (equal (read "+1.25e-1") 0.125)) + (should (equal (read "-1.25e-1") -0.125)) + (should (equal (read "4.e3") 4000.0)) + (should (equal (read "+4.e3") 4000.0)) + (should (equal (read "-4.e3") -4000.0)) + (should (equal (read "4.e+3") 4000.0)) + (should (equal (read "+4.e+3") 4000.0)) + (should (equal (read "-4.e+3") -4000.0)) + (should (equal (read "5.e-1") 0.5)) + (should (equal (read "+5.e-1") 0.5)) + (should (equal (read "-5.e-1") -0.5)) + (should (equal (read "0") 0)) + (should (equal (read "+0") 0)) + (should (equal (read "-0") 0)) + (should (equal (read "0.") 0)) + (should (equal (read "+0.") 0)) + (should (equal (read "-0.") 0)) + (should (equal (read "0.0") 0.0)) + (should (equal (read "+0.0") 0.0)) + (should (equal (read "-0.0") -0.0)) + (should (equal (read "0e5") 0.0)) + (should (equal (read "+0e5") 0.0)) + (should (equal (read "-0e5") -0.0)) + (should (equal (read "0e-5") 0.0)) + (should (equal (read "+0e-5") 0.0)) + (should (equal (read "-0e-5") -0.0)) + (should (equal (read ".0e-5") 0.0)) + (should (equal (read "+.0e-5") 0.0)) + (should (equal (read "-.0e-5") -0.0)) + (should (equal (read "0.0e-5") 0.0)) + (should (equal (read "+0.0e-5") 0.0)) + (should (equal (read "-0.0e-5") -0.0)) + (should (equal (read "0.e-5") 0.0)) + (should (equal (read "+0.e-5") 0.0)) + (should (equal (read "-0.e-5") -0.0)) + ) + + ;;; lread-tests.el ends here diff --git a/test/src/process-tests.el b/test/src/process-tests.el index e62bcb3f7c0..9bab523708e 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -26,9 +26,9 @@ (require 'cl-lib) (require 'ert) (require 'puny) -(require 'rx) (require 'subr-x) (require 'dns) +(require 'url-http) ;; Timeout in seconds; the test fails if the timeout is reached. (defvar process-test-sentinel-wait-timeout 2.0) @@ -348,8 +348,7 @@ See Bug#30460." invocation-directory)) :stop t)))) -;; All the following tests require working DNS, which appears not to -;; be the case for hydra.nixos.org, so disable them there for now. +;; The following tests require working DNS ;; This will need updating when IANA assign more IPv6 global ranges. (defun ipv6-is-available () @@ -360,9 +359,16 @@ See Bug#30460." (= (logand (aref elt 0) #xe000) #x2000))) (network-interface-list)))) +;; Check if the Internet seems to be working. Mainly to pacify +;; Debian's CI system. +(defvar internet-is-working + (progn + (require 'dns) + (dns-query "google.com"))) + (ert-deftest lookup-family-specification () "`network-lookup-address-info' should only accept valid family symbols." - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (skip-unless internet-is-working) (with-timeout (60 (ert-fail "Test timed out")) (should-error (network-lookup-address-info "localhost" 'both)) (should (network-lookup-address-info "localhost" 'ipv4)) @@ -371,20 +377,20 @@ See Bug#30460." (ert-deftest lookup-unicode-domains () "Unicode domains should fail." - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (skip-unless internet-is-working) (with-timeout (60 (ert-fail "Test timed out")) (should-error (network-lookup-address-info "faß.de")) (should (network-lookup-address-info (puny-encode-domain "faß.de"))))) (ert-deftest unibyte-domain-name () "Unibyte domain names should work." - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (skip-unless internet-is-working) (with-timeout (60 (ert-fail "Test timed out")) (should (network-lookup-address-info (string-to-unibyte "google.com"))))) (ert-deftest lookup-google () "Check that we can look up google IP addresses." - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (skip-unless internet-is-working) (with-timeout (60 (ert-fail "Test timed out")) (let ((addresses-both (network-lookup-address-info "google.com")) (addresses-v4 (network-lookup-address-info "google.com" 'ipv4))) @@ -396,10 +402,12 @@ See Bug#30460." (ert-deftest non-existent-lookup-failure () "Check that looking up non-existent domain returns nil." - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (skip-unless internet-is-working) (with-timeout (60 (ert-fail "Test timed out")) (should (eq nil (network-lookup-address-info "emacs.invalid"))))) +;; End of tests requiring DNS + (defmacro process-tests--ignore-EMFILE (&rest body) "Evaluate BODY, ignoring EMFILE errors." (declare (indent 0) (debug t)) @@ -619,6 +627,8 @@ FD_SETSIZE file descriptors (Bug#24325)." FD_SETSIZE file descriptors (Bug#24325)." (skip-unless (featurep 'make-network-process '(:server t))) (skip-unless (featurep 'make-network-process '(:family local))) + ;; Avoid hang due to connect/accept handshake on Cygwin (bug#49496). + (skip-unless (not (eq system-type 'cygwin))) (with-timeout (60 (ert-fail "Test timed out")) (process-tests--with-temp-directory directory (process-tests--with-processes processes @@ -907,5 +917,34 @@ Return nil if FILENAME doesn't exist." ;; ...and the change description should be "interrupt". (should (equal '("interrupt\n") events))))) +(ert-deftest process-async-https-with-delay () + "Bug#49449: asynchronous TLS connection with delayed completion." + (skip-unless (and internet-is-working (gnutls-available-p))) + (let* ((status nil) + (buf (url-http + #s(url "https" nil nil "elpa.gnu.org" nil + "/packages/archive-contents" nil nil t silent t t) + (lambda (s) (setq status s)) + '(nil) nil 'tls))) + (unwind-protect + (progn + ;; Busy-wait for 1 s to allow for the TCP connection to complete. + (let ((delay 1.0) + (t0 (float-time))) + (while (< (float-time) (+ t0 delay)))) + ;; Wait for the entire operation to finish. + (let ((limit 4.0) + (t0 (float-time))) + (while (and (null status) + (< (float-time) (+ t0 limit))) + (sit-for 0.1))) + (should status) + (should-not (assq :error status)) + (should buf) + (should (> (buffer-size buf) 0)) + ) + (when buf + (kill-buffer buf))))) + (provide 'process-tests) ;;; process-tests.el ends here diff --git a/test/src/search-tests.el b/test/src/search-tests.el new file mode 100644 index 00000000000..b7b4ab9a8ff --- /dev/null +++ b/test/src/search-tests.el @@ -0,0 +1,42 @@ +;;; search-tests.el --- tests for search.c functions -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2016, 2018-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/>. + +;;; Code: + +(require 'ert) + +(ert-deftest test-replace-match-modification-hooks () + (let ((ov-set nil)) + (with-temp-buffer + (insert "1 abc") + (setq ov-set (make-overlay 3 5)) + (overlay-put + ov-set 'modification-hooks + (list (lambda (o after &rest _args) + (when after + (let ((inhibit-modification-hooks t)) + (save-excursion + (goto-char 2) + (insert "234"))))))) + (goto-char 3) + (if (search-forward "bc") + (replace-match "bcd")) + (should (= (point) 10))))) + +;;; search-tests.el ends here diff --git a/test/src/syntax-tests.el b/test/src/syntax-tests.el index 479b818935f..e4e3054d37a 100644 --- a/test/src/syntax-tests.el +++ b/test/src/syntax-tests.el @@ -21,6 +21,7 @@ (require 'ert) (require 'ert-x) +(require 'cl-lib) (ert-deftest parse-partial-sexp-continue-over-comment-marker () "Continue a parse that stopped in the middle of a comment marker." @@ -56,6 +57,16 @@ (should (equal (parse-partial-sexp aftC pointX nil nil pps-aftC) ppsX))))) +(ert-deftest syntax-class-character-test () + (cl-loop for char across " .w_()'\"$\\/<>@!|" + for i from 0 + do (should (= char (syntax-class-to-char i))) + when (string-to-syntax (string char)) + do (should (= char (syntax-class-to-char + (car (string-to-syntax (string char))))))) + (should-error (syntax-class-to-char -1)) + (should-error (syntax-class-to-char 200))) + (ert-deftest parse-partial-sexp-paren-comments () "Test syntax parsing with paren comment markers. Specifically, where the first character of the comment marker is diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index f14d2426ef0..fc7bc7441b7 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -1,4 +1,4 @@ -;;; threads.el --- tests for threads. -*- lexical-binding: t -*- +;;; thread-tests.el --- tests for threads. -*- lexical-binding: t -*- ;; Copyright (C) 2012-2021 Free Software Foundation, Inc. @@ -315,8 +315,8 @@ "Test signaling a thread as soon as it is started by the OS." (skip-unless (featurep 'threads)) (let ((thread - (make-thread #'(lambda () - (while t (thread-yield)))))) + (make-thread (lambda () + (while t (thread-yield)))))) (thread-signal thread 'error nil) (sit-for 1) (should-not (thread-live-p thread)) @@ -331,7 +331,7 @@ (let (buffer-read-only) (erase-buffer)) (let ((thread - (make-thread #'(lambda () (thread-signal main-thread 'error nil))))) + (make-thread (lambda () (thread-signal main-thread 'error nil))))) (while (thread-live-p thread) (thread-yield)) (read-event nil nil 0.1) diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index e55bd1eb4ee..0a450a7573f 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -1,4 +1,4 @@ -;;; timefns-tests.el -- tests for timefns.c -*- lexical-binding: t -*- +;;; timefns-tests.el --- tests for timefns.c -*- lexical-binding: t -*- ;; Copyright (C) 2016-2021 Free Software Foundation, Inc. diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index 055bf102dfc..a658bccf6dc 100644 --- a/test/src/undo-tests.el +++ b/test/src/undo-tests.el @@ -46,6 +46,7 @@ ;;; Code: (require 'ert) +(require 'facemenu) (ert-deftest undo-test0 () "Test basics of \\[undo]." @@ -87,6 +88,7 @@ (ert-deftest undo-test1 () "Test undo of \\[undo] command (redo)." + (require 'facemenu) (with-temp-buffer (buffer-enable-undo) (undo-boundary) |