diff options
Diffstat (limited to 'test/src/eval-tests.el')
| -rw-r--r-- | test/src/eval-tests.el | 206 |
1 files changed, 187 insertions, 19 deletions
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index 7ff60dd01c4..bb2f04e8ee1 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -1,6 +1,6 @@ ;;; eval-tests.el --- unit tests for src/eval.c -*- lexical-binding: t; -*- -;; Copyright (C) 2016-2017 Free Software Foundation, Inc. +;; Copyright (C) 2016-2022 Free Software Foundation, Inc. ;; Author: Philipp Stephani <phst@google.com> @@ -26,28 +26,53 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'cl-lib)) +(require 'subr-x) (ert-deftest eval-tests--bug24673 () - "Checks that Bug#24673 has been fixed." + "Check that Bug#24673 has been fixed." ;; This should not crash. (should-error (funcall '(closure)) :type 'invalid-function)) (defvar byte-compile-debug) (ert-deftest eval-tests--bugs-24912-and-24913 () - "Checks that Emacs doesn’t accept weird argument lists. + "Check that Emacs doesn't accept weird argument lists. Bug#24912 and Bug#24913." - (dolist (args '((&optional) (&rest) (&optional &rest) (&rest &optional) - (&optional &rest a) (&optional a &rest) - (&rest a &optional) (&rest &optional a) - (&optional &optional) (&optional &optional a) - (&optional a &optional b) - (&rest &rest) (&rest &rest a) - (&rest a &rest b))) - (should-error (eval `(funcall (lambda ,args)) t) :type 'invalid-function) - (should-error (byte-compile-check-lambda-list args)) - (let ((byte-compile-debug t)) - (should-error (eval `(byte-compile (lambda ,args)) t))))) + (dolist (lb '(t false)) + (ert-info ((prin1-to-string lb) :prefix "lexical-binding: ") + (let ((lexical-binding lb)) + (dolist (args '((&rest &optional) + (&rest a &optional) (&rest &optional a) + (&optional &optional) (&optional &optional a) + (&optional a &optional b) + (&rest &rest) (&rest &rest a) + (&rest a &rest b) + (&rest) (&optional &rest) + )) + (ert-info ((prin1-to-string args) :prefix "args: ") + (should-error + (eval `(funcall (lambda ,args)) lb) :type 'invalid-function) + (should-error (byte-compile-check-lambda-list args)) + (let ((byte-compile-debug t)) + (should-error (eval `(byte-compile (lambda ,args)) lb))))))))) + +(ert-deftest eval-tests-accept-empty-optional () + "Check that Emacs accepts empty &optional arglists. +Bug#24912." + (dolist (lb '(t false)) + (ert-info ((prin1-to-string lb) :prefix "lexical-binding: ") + (let ((lexical-binding lb)) + (dolist (args '((&optional) (&optional &rest a))) + (ert-info ((prin1-to-string args) :prefix "args: ") + (let ((fun `(lambda ,args 'ok))) + (ert-info ("eval") + (should (eq (funcall (eval fun lb)) 'ok))) + (ert-info ("byte comp check") + (byte-compile-check-lambda-list args)) + (ert-info ("bytecomp") + (let ((byte-compile-debug t)) + (should (eq (funcall (byte-compile fun)) 'ok))))))))))) (dolist (form '(let let*)) @@ -61,22 +86,165 @@ Bug#24912 and Bug#24913." (ert-deftest eval-tests--if-dot-string () "Check that Emacs rejects (if . \"string\")." - (should-error (eval '(if . "abc")) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") nil) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") t) :type 'wrong-type-argument) (let ((if-tail (list '(setcdr if-tail "abc") t))) - (should-error (eval (cons 'if if-tail)))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable)) (let ((if-tail (list '(progn (setcdr if-tail "abc") nil) t))) - (should-error (eval (cons 'if if-tail))))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable))) (ert-deftest eval-tests--let-with-circular-defs () "Check that Emacs reports an error for (let VARS ...) when VARS is circular." (let ((vars (list 'v))) (setcdr vars vars) (dolist (let-sym '(let let*)) - (should-error (eval (list let-sym vars)))))) + (should-error (eval (list let-sym vars) nil))))) (ert-deftest eval-tests--mutating-cond () "Check that Emacs doesn't crash on a cond clause that mutates during eval." (let ((clauses (list '((progn (setcdr clauses "ouch") nil))))) - (should-error (eval (cons 'cond clauses))))) + (should-error (eval (cons 'cond clauses) nil)) + (should-error (eval (cons 'cond clauses) t)))) + +(ert-deftest defvar/bug31072 () + "Check that Bug#31072 is fixed." + (should-error (eval '(defvar 1) t) :type 'wrong-type-argument)) + +(ert-deftest defvaralias-overwrite-warning () + "Test for Bug#5950." + (defvar eval-tests--foo) + (setq eval-tests--foo 2) + (defvar eval-tests--foo-alias) + (setq eval-tests--foo-alias 1) + (cl-letf (((symbol-function 'display-warning) + (lambda (type &rest _) + (throw 'got-warning type)))) + ;; Warn if we lose a value through aliasing. + (should (equal + '(defvaralias losing-value eval-tests--foo-alias) + (catch 'got-warning + (defvaralias 'eval-tests--foo-alias 'eval-tests--foo)))) + ;; Don't warn if we don't. + (makunbound 'eval-tests--foo-alias) + (should (eq 'no-warning + (catch 'got-warning + (defvaralias 'eval-tests--foo-alias 'eval-tests--foo) + 'no-warning))))) + +(ert-deftest eval-tests-byte-code-being-evaluated-is-protected-from-gc () + "Regression test for Bug#33014. +Check that byte-compiled objects being executed by exec-byte-code +are found on the stack and therefore not garbage collected." + (should (string= (eval-tests-33014-func) + "before after: ok foo: (e) bar: (a b c d e) baz: a bop: c"))) + +(defvar eval-tests-33014-var "ok") +(defun eval-tests-33014-func () + "A function which has a non-trivial constants vector when byte-compiled." + (let ((result "before ")) + (eval-tests-33014-redefine) + (garbage-collect) + (setq result (concat result (format "after: %s" eval-tests-33014-var))) + (let ((vals '(0 1 2 3)) + (things '(a b c d e))) + (dolist (val vals) + (setq result + (concat result " " + (cond + ((= val 0) (format "foo: %s" (last things))) + ((= val 1) (format "bar: %s" things)) + ((= val 2) (format "baz: %s" (car things))) + (t (format "bop: %s" (nth 2 things)))))))) + result)) + +(defun eval-tests-33014-redefine () + "Remove the Lisp reference to the byte-compiled object." + (setf (symbol-function #'eval-tests-33014-func) nil)) + +(ert-deftest eval-tests-19790-backquote-comma-dot-substitution () + "Regression test for Bug#19790. +Don't handle destructive splicing in backquote expressions (like +in Common Lisp). Instead, make sure substitution in backquote +expressions works for identifiers starting with period." + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) nil)) 'ok)) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) t)) 'ok))) + +(ert-deftest eval-tests/backtrace-in-batch-mode () + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + (with-temp-buffer + (let ((status (call-process emacs nil t nil + "--quick" "--batch" + (concat "--eval=" + (prin1-to-string + '(progn + (defun foo () (error "Boo")) + (foo))))))) + (should (natnump status)) + (should-not (eql status 0))) + (goto-char (point-min)) + (ert-info ((concat "Process output:\n" (buffer-string))) + (search-forward " foo()") + (search-forward " normal-top-level()"))))) + +(ert-deftest eval-tests/backtrace-in-batch-mode/inhibit () + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + (with-temp-buffer + (let ((status (call-process + emacs nil t nil + "--quick" "--batch" + (concat "--eval=" + (prin1-to-string + '(progn + (defun foo () (error "Boo")) + (let ((backtrace-on-error-noninteractive nil)) + (foo)))))))) + (should (natnump status)) + (should-not (eql status 0))) + (should (equal (string-trim (buffer-string)) "Boo"))))) + +(ert-deftest eval-tests/backtrace-in-batch-mode/demoted-errors () + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + (with-temp-buffer + (should (eql 0 (call-process emacs nil t nil + "--quick" "--batch" + (concat "--eval=" + (prin1-to-string + '(with-demoted-errors "Error: %S" + (error "Boo"))))))) + (goto-char (point-min)) + (should (equal (string-trim (buffer-string)) + "Error: (error \"Boo\")"))))) + +(ert-deftest eval-tests/funcall-with-delayed-message () + ;; Check that `funcall-with-delayed-message' displays its message before + ;; its function terminates iff the timeout is short enough. + + ;; This also serves as regression test for bug#55628 where a short + ;; timeout was rounded up to the next whole second. + (dolist (params '((0.8 0.4) + (0.1 0.8))) + (let ((timeout (nth 0 params)) + (work-time (nth 1 params))) + (ert-info ((prin1-to-string params) :prefix "params: ") + (with-current-buffer "*Messages*" + (let ((inhibit-read-only t)) + (erase-buffer)) + (let ((stop (+ (float-time) work-time))) + (funcall-with-delayed-message + timeout "timed out" + (lambda () + (while (< (float-time) stop)) + (message "finished")))) + (let ((expected-messages + (if (< timeout work-time) + "timed out\nfinished" + "finished"))) + (should (equal (string-trim (buffer-string)) + expected-messages)))))))) ;;; eval-tests.el ends here |