diff options
Diffstat (limited to 'test/lisp/emacs-lisp/bytecomp-tests.el')
| -rw-r--r-- | test/lisp/emacs-lisp/bytecomp-tests.el | 264 |
1 files changed, 241 insertions, 23 deletions
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index c399f65b402..5bd36898702 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -27,6 +27,8 @@ (require 'ert) (require 'cl-lib) +(require 'subr-x) +(require 'bytecomp) ;;; Code: (defconst byte-opt-testsuite-arith-data @@ -38,8 +40,7 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (+ a -1 b)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (- a 1 (- b))) - ;; This fails. Should it be a bug? - ;; (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) + (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) (let ((a 1.0)) (* a 0)) (let ((a 1.0)) (* a 2.0 0)) (let ((a 1.0)) (/ 0 a)) @@ -244,6 +245,9 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) (let ((a 3) (b 2) (c 1.0)) (/ a b c -1)) + + (let ((a t)) (logand 0 a)) + ;; Test switch bytecode (let ((a 3)) (cond ((eq a 1) 'one) ((eq a 2) 'two) ((eq a 3) 'three) (t t))) (let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3) @@ -293,7 +297,57 @@ ((eq variable 'default) (message "equal")) (t - (message "not equal"))))) + (message "not equal")))) + ;; Bug#35770 + (let ((x 'a)) (cond ((eq x 'a) 'correct) + ((eq x 'b) 'incorrect) + ((eq x 'a) 'incorrect) + ((eq x 'c) 'incorrect))) + (let ((x #x10000000000000000)) + (cond ((eql x #x10000000000000000) 'correct) + ((eql x #x10000000000000001) 'incorrect) + ((eql x #x10000000000000000) 'incorrect) + ((eql x #x10000000000000002) 'incorrect))) + (let ((x "a")) (cond ((equal x "a") 'correct) + ((equal x "b") 'incorrect) + ((equal x "a") 'incorrect) + ((equal x "c") 'incorrect))) + ;; Multi-value clauses + (mapcar (lambda (x) (cond ((eq x 'a) 11) + ((memq x '(b a c d)) 22) + ((eq x 'c) 33) + ((eq x 'e) 44) + ((memq x '(d f g)) 55) + (t 99))) + '(a b c d e f g h)) + (mapcar (lambda (x) (cond ((eql x 1) 11) + ((memq x '(a b c)) 22) + ((memql x '(2 1 4 1e-3)) 33) + ((eq x 'd) 44) + ((eql x #x10000000000000000)))) + '(1 2 4 1e-3 a b c d 1.0 #x10000000000000000)) + (mapcar (lambda (x) (cond ((eq x 'a) 11) + ((memq x '(b d)) 22) + ((equal x '(a . b)) 33) + ((member x '(b c 1.5 2.5 "X" (d))) 44) + ((eql x 3.14) 55) + ((memql x '(9 0.5 1.5 q)) 66) + (t 99))) + '(a b c d (d) (a . b) "X" 0.5 1.5 3.14 9 9.0)) + ;; Multi-switch cond form + (mapcar (lambda (p) (let ((x (car p)) (y (cadr p))) + (cond ((consp x) 11) + ((eq x 'a) 22) + ((memql x '(b 7 a -3)) 33) + ((equal y "a") 44) + ((memq y '(c d e)) 55) + ((booleanp x) 66) + ((eq x 'q) 77) + ((memq x '(r s)) 88) + ((eq x 't) 99) + (t 999)))) + '((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c) + (t c) (x "a") (x "c") (x c) (x d) (x e)))) "List of expression for test. Each element will be executed by interpreter and with bytecompiled code, and their results compared.") @@ -541,37 +595,39 @@ bytecompiled code, and their results compared.") "Check that byte compiling warns about unescaped character literals (Bug#20852)." (should (boundp 'lread--unescaped-character-literals)) - (bytecomp-tests--with-temp-file source - (write-region "(list ?) ?( ?; ?\" ?[ ?])" nil source) - (bytecomp-tests--with-temp-file destination - (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-error-on-warn t) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) - (list (concat "unescaped character literals " - "`?\"', `?(', `?)', `?;', `?[', `?]' " - "detected!")))))))) + (let ((byte-compile-error-on-warn t) + (byte-compile-debug t)) + (bytecomp-tests--with-temp-file source + (write-region "(list ?) ?( ?; ?\" ?[ ?])" nil source) + (bytecomp-tests--with-temp-file destination + (let* ((byte-compile-dest-file-function (lambda (_) destination)) + (err (should-error (byte-compile-file source)))) + (should (equal (cdr err) + `(,(concat "unescaped character literals " + "`?\"', `?(', `?)', `?;', `?[', `?]' " + "detected, " + "`?\\\"', `?\\(', `?\\)', `?\\;', `?\\[', " + "`?\\]' expected!"))))))) + ;; But don't warn in subsequent compilations (Bug#36068). + (bytecomp-tests--with-temp-file source + (write-region "(list 1 2 3)" nil source) + (bytecomp-tests--with-temp-file destination + (let ((byte-compile-dest-file-function (lambda (_) destination))) + (should (byte-compile-file source))))))) (ert-deftest bytecomp-tests--old-style-backquotes () "Check that byte compiling warns about old-style backquotes." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (write-region "(` (a b))" nil source) (bytecomp-tests--with-temp-file destination (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-error-on-warn t) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) - (list "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual."))))))) + (byte-compile-debug t) + (err (should-error (byte-compile-file source)))) + (should (equal (cdr err) '("Old-style backquotes detected!"))))))) (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1) (function-put 'bytecomp-tests--foo 'bar 2) @@ -596,6 +652,168 @@ and will be removed soon. See (elisp)Backquote in the manual."))))))) (goto-char (point-min)) (should-not (search-forward "Warning" nil t)))) +(ert-deftest bytecomp-test-featurep-warnings () + (let ((byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + (unwind-protect + (progn + (with-temp-buffer + (insert "\ +\(defun foo () + (an-undefined-function)) + +\(defun foo1 () + (if (featurep 'xemacs) + (some-undefined-function-if))) + +\(defun foo2 () + (and (featurep 'xemacs) + (some-undefined-function-and))) + +\(defun foo3 () + (if (not (featurep 'emacs)) + (some-undefined-function-not))) + +\(defun foo4 () + (or (featurep 'emacs) + (some-undefined-function-or))) +") + (byte-compile-from-buffer (current-buffer))) + (with-current-buffer byte-compile-log-buffer + (should (search-forward "an-undefined-function" nil t)) + (should-not (search-forward "some-undefined-function" nil t)))) + (if (buffer-live-p byte-compile-log-buffer) + (kill-buffer byte-compile-log-buffer))))) + +(ert-deftest bytecomp-test--switch-duplicates () + "Check that duplicates in switches are eliminated correctly (bug#35770)." + (dolist (params + '(((lambda (x) + (cond ((eq x 'a) 111) + ((eq x 'b) 222) + ((eq x 'a) 333) + ((eq x 'c) 444))) + (a b c) + string<) + ((lambda (x) + (cond ((eql x #x10000000000000000) 111) + ((eql x #x10000000000000001) 222) + ((eql x #x10000000000000000) 333) + ((eql x #x10000000000000002) 444))) + (#x10000000000000000 #x10000000000000001 #x10000000000000002) + <) + ((lambda (x) + (cond ((equal x "a") 111) + ((equal x "b") 222) + ((equal x "a") 333) + ((equal x "c") 444))) + ("a" "b" "c") + string<))) + (let* ((lisp (nth 0 params)) + (keys (nth 1 params)) + (lessp (nth 2 params)) + (bc (byte-compile lisp)) + (lap (byte-decompile-bytecode (aref bc 1) (aref bc 2))) + ;; Assume the first constant is the switch table. + (table (cadr (assq 'byte-constant lap)))) + (should (hash-table-p table)) + (should (equal (sort (hash-table-keys table) lessp) keys)) + (should (member '(byte-constant 111) lap)) + (should (member '(byte-constant 222) lap)) + (should-not (member '(byte-constant 333) lap)) + (should (member '(byte-constant 444) lap))))) + +(defun test-suppression (form suppress match) + (let ((lexical-binding t) + (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + ;; Check that we get a warning without suppression. + (with-current-buffer byte-compile-log-buffer + (setq-local fill-column 9999) + (setq-local warning-fill-column fill-column) + (let ((inhibit-read-only t)) + (erase-buffer))) + (test-byte-comp-compile-and-load t form) + (with-current-buffer byte-compile-log-buffer + (unless match + (error "%s" (buffer-string))) + (goto-char (point-min)) + (should (string-match match (buffer-string)))) + ;; And that it's gone now. + (with-current-buffer byte-compile-log-buffer + (let ((inhibit-read-only t)) + (erase-buffer))) + (test-byte-comp-compile-and-load t + `(with-suppressed-warnings ,suppress + ,form)) + (with-current-buffer byte-compile-log-buffer + (goto-char (point-min)) + (should-not (string-match match (buffer-string)))) + ;; Also check that byte compiled forms are identical. + (should (equal (byte-compile form) + (byte-compile + `(with-suppressed-warnings ,suppress ,form)))))) + +(ert-deftest bytecomp-test--with-suppressed-warnings () + (test-suppression + '(defvar prefixless) + '((lexical prefixless)) + "global/dynamic var .prefixless. lacks") + + (test-suppression + '(defun foo() + (let ((nil t)) + (message-mail))) + '((constants nil)) + "Warning: attempt to let-bind constant .nil.") + + (test-suppression + '(progn + (defun obsolete () + (declare (obsolete foo "22.1"))) + (defun zot () + (obsolete))) + '((obsolete obsolete)) + "Warning: .obsolete. is an obsolete function") + + (test-suppression + '(progn + (defun wrong-params (foo &optional unused) + (ignore unused) + foo) + (defun zot () + (wrong-params 1 2 3))) + '((callargs wrong-params)) + "Warning: wrong-params called with") + + (test-byte-comp-compile-and-load nil + (defvar obsolete-variable nil) + (make-obsolete-variable 'obsolete-variable nil "24.1")) + (test-suppression + '(defun zot () + obsolete-variable) + '((obsolete obsolete-variable)) + "obsolete") + + (test-suppression + '(defun zot () + (mapcar #'list '(1 2 3)) + nil) + '((mapcar mapcar)) + "Warning: .mapcar. called for effect") + + (test-suppression + '(defun zot () + free-variable) + '((free-vars free-variable)) + "Warning: reference to free variable") + + (test-suppression + '(defun zot () + (save-excursion + (set-buffer (get-buffer-create "foo")) + nil)) + '((suspicious set-buffer)) + "Warning: Use .with-current-buffer. rather than")) + ;; Local Variables: ;; no-byte-compile: t ;; End: |