diff options
Diffstat (limited to 'test/lisp/emacs-lisp/bytecomp-tests.el')
| -rw-r--r-- | test/lisp/emacs-lisp/bytecomp-tests.el | 240 |
1 files changed, 231 insertions, 9 deletions
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 7ae10cdea73..9ade47331df 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -704,6 +704,68 @@ inner loops respectively." (let ((bytecomp-tests--xx 1)) (set (make-local-variable 'bytecomp-tests--xx) 2) bytecomp-tests--xx) + + ;; Check for-effect optimisation of `condition-case' body form. + ;; With `condition-case' in for-effect context: + (let ((x (bytecomp-test-identity ?A)) + (r nil)) + (condition-case e + (characterp x) ; value (:success, var) + (error (setq r 'bad)) + (:success (setq r (list 'good e)))) + r) + (let ((x (bytecomp-test-identity ?B)) + (r nil)) + (condition-case nil + (characterp x) ; for-effect (:success, no var) + (error (setq r 'bad)) + (:success (setq r 'good))) + r) + (let ((x (bytecomp-test-identity ?C)) + (r nil)) + (condition-case e + (characterp x) ; for-effect (no :success, var) + (error (setq r (list 'bad e)))) + r) + (let ((x (bytecomp-test-identity ?D)) + (r nil)) + (condition-case nil + (characterp x) ; for-effect (no :success, no var) + (error (setq r 'bad))) + r) + ;; With `condition-case' in value context: + (let ((x (bytecomp-test-identity ?E))) + (condition-case e + (characterp x) ; for-effect (:success, var) + (error (list 'bad e)) + (:success (list 'good e)))) + (let ((x (bytecomp-test-identity ?F))) + (condition-case nil + (characterp x) ; for-effect (:success, no var) + (error 'bad) + (:success 'good))) + (let ((x (bytecomp-test-identity ?G))) + (condition-case e + (characterp x) ; value (no :success, var) + (error (list 'bad e)))) + (let ((x (bytecomp-test-identity ?H))) + (condition-case nil + (characterp x) ; value (no :success, no var) + (error 'bad))) + + (condition-case nil + (bytecomp-test-identity 3) + (error 'bad) + (:success)) ; empty handler + + ;; `cond' miscompilation bug + (let ((fn (lambda (x) + (let ((y nil)) + (cond ((progn (setq x (1+ x)) (> x 10)) (setq y 'a)) + ((eq x 1) (setq y 'b)) + ((eq x 2) (setq y 'c))) + (list x y))))) + (mapcar fn (bytecomp-test-identity '(0 1 2 3 10 11)))) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -833,13 +895,28 @@ byte-compiled. Run with dynamic binding." ;; Should not warn that mt--test2 is not known to be defined. (should-not (re-search-forward "my--test2" nil t)))) -(defmacro bytecomp--with-warning-test (re-warning &rest form) +(defun bytecomp--with-warning-test (re-warning form) (declare (indent 1)) - `(with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create "*Compile-Log*") (let ((inhibit-read-only t)) (erase-buffer)) - (byte-compile ,@form) - (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") - (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning)))))) + (let ((text-quoting-style 'grave) + (macroexp--warned ; oh dear + (make-hash-table :test #'equal :weakness 'key))) + (ert-info ((prin1-to-string form) :prefix "form: ") + (byte-compile form) + (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") + (should (re-search-forward + (string-replace " " "[ \n]+" re-warning)))))))) + +(ert-deftest bytecomp-warn--ignore () + (bytecomp--with-warning-test "unused" + '(lambda (y) 6)) + (bytecomp--with-warning-test "\\`\\'" ;No warning! + '(lambda (y) (ignore y) 6)) + (bytecomp--with-warning-test "assq" + '(lambda (x y) (progn (assq x y) 5))) + (bytecomp--with-warning-test "\\`\\'" ;No warning! + '(lambda (x y) (progn (ignore (assq x y)) 5)))) (ert-deftest bytecomp-warn-wrong-args () (bytecomp--with-warning-test "remq.*3.*2" @@ -863,6 +940,66 @@ byte-compiled. Run with dynamic binding." (bytecomp--with-warning-test "defvar.*foo.*wider than.*characters" `(defvar foo t ,bytecomp-tests--docstring))) +(ert-deftest bytecomp-warn-quoted-condition () + (bytecomp--with-warning-test + "Warning: `condition-case' condition should not be quoted: 'arith-error" + '(condition-case nil + (abc) + ('arith-error "ugh"))) + (bytecomp--with-warning-test + "Warning: `ignore-error' condition argument should not be quoted: 'error" + '(ignore-error 'error (abc)))) + +(ert-deftest bytecomp-warn-dodgy-args-eq () + (dolist (fn '(eq eql)) + (cl-flet ((msg (type arg) + (format + "`%s' called with literal %s that may never match (arg %d)" + fn type arg))) + (bytecomp--with-warning-test (msg "list" 1) `(,fn '(a) 'x)) + (bytecomp--with-warning-test (msg "string" 2) `(,fn 'x "a")) + (bytecomp--with-warning-test (msg "vector" 2) `(,fn 'x [a])) + (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x (lambda () 1))) + (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x #'(lambda () 1))) + (unless (eq fn 'eql) + (bytecomp--with-warning-test (msg "integer" 2) `(,fn 'x #x10000000000)) + (bytecomp--with-warning-test (msg "float" 2) `(,fn 'x 1.0)))))) + +(ert-deftest bytecomp-warn-dodgy-args-memq () + (dolist (fn '(memq memql remq delq assq rassq)) + (cl-labels + ((msg1 (type) + (format + "`%s' called with literal %s that may never match (arg 1)" + fn type)) + (msg2 (type) + (format + "`%s' called with literal %s that may never match (element 2 of arg 2)" + fn type)) + (lst (elt) + (cond ((eq fn 'assq) `((a . 1) (,elt . 2) (c . 3))) + ((eq fn 'rassq) `((1 . a) (2 . ,elt) (3 . c))) + (t `(a ,elt c)))) + (form2 (elt) + `(,fn 'x ',(lst elt)))) + + (bytecomp--with-warning-test (msg1 "list") `(,fn '(a) '(x))) + (bytecomp--with-warning-test (msg1 "string") `(,fn "a" '(x))) + (bytecomp--with-warning-test (msg1 "vector") `(,fn [a] '(x))) + (bytecomp--with-warning-test (msg1 "function") `(,fn (lambda () 1) '(x))) + (bytecomp--with-warning-test (msg1 "function") `(,fn #'(lambda () 1) '(x))) + (unless (eq fn 'memql) + (bytecomp--with-warning-test (msg1 "integer") `(,fn #x10000000000 '(x))) + (bytecomp--with-warning-test (msg1 "float") `(,fn 1.0 '(x)))) + + (bytecomp--with-warning-test (msg2 "list") (form2 '(b))) + (bytecomp--with-warning-test (msg2 "list") (form2 ''b)) + (bytecomp--with-warning-test (msg2 "string") (form2 "b")) + (bytecomp--with-warning-test (msg2 "vector") (form2 [b])) + (unless (eq fn 'memql) + (bytecomp--with-warning-test (msg2 "integer") (form2 #x10000000000)) + (bytecomp--with-warning-test (msg2 "float") (form2 1.0)))))) + (defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse) `(ert-deftest ,(intern (format "bytecomp/%s" file)) () (with-current-buffer (get-buffer-create "*Compile-Log*") @@ -1094,7 +1231,8 @@ byte-compiled. Run with dynamic binding." literals (Bug#20852)." (should (boundp 'lread--unescaped-character-literals)) (let ((byte-compile-error-on-warn t) - (byte-compile-debug t)) + (byte-compile-debug t) + (text-quoting-style 'grave)) (bytecomp-tests--with-temp-file source (write-region "(list ?) ?( ?; ?\" ?[ ?])" nil source) (bytecomp-tests--with-temp-file destination @@ -1213,6 +1351,7 @@ literals (Bug#20852)." (defun test-suppression (form suppress match) (let ((lexical-binding t) + (text-quoting-style 'grave) (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) ;; Check that we get a warning without suppression. (with-current-buffer byte-compile-log-buffer @@ -1299,8 +1438,8 @@ literals (Bug#20852)." '(defun zot () (mapcar #'list '(1 2 3)) nil) - '((mapcar mapcar)) - "Warning: .mapcar. called for effect") + '((ignored-return-value mapcar)) + "Warning: value from call to `mapcar' is unused; use `mapc' or `dolist' instead") (test-suppression '(defun zot () @@ -1314,7 +1453,62 @@ literals (Bug#20852)." (set-buffer (get-buffer-create "foo")) nil)) '((suspicious set-buffer)) - "Warning: Use .with-current-buffer. rather than")) + "Warning: Use .with-current-buffer. rather than") + + (test-suppression + '(defun zot (x) + (condition-case nil (list x))) + '((suspicious condition-case)) + "Warning: `condition-case' without handlers") + + (test-suppression + '(defun zot (x) + (unwind-protect (print x))) + '((suspicious unwind-protect)) + "Warning: `unwind-protect' without unwind forms") + + (test-suppression + '(defun zot () + (let ((_ 1)) + )) + '((empty-body let)) + "Warning: `let' with empty body") + + (test-suppression + '(defun zot () + (let* ((_ 1)) + )) + '((empty-body let*)) + "Warning: `let\\*' with empty body") + + (test-suppression + '(defun zot (x) + (when x + )) + '((empty-body when)) + "Warning: `when' with empty body") + + (test-suppression + '(defun zot (x) + (unless x + )) + '((empty-body unless)) + "Warning: `unless' with empty body") + + (test-suppression + '(defun zot (x) + (ignore-error arith-error + )) + '((empty-body ignore-error)) + "Warning: `ignore-error' with empty body") + + (test-suppression + '(defun zot (x) + (with-suppressed-warnings ((suspicious eq)) + )) + '((empty-body with-suppressed-warnings)) + "Warning: `with-suppressed-warnings' with empty body") + ) (ert-deftest bytecomp-tests--not-writable-directory () "Test that byte compilation works if the output directory isn't @@ -1662,6 +1856,34 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \ (should (eq (byte-compile-file src-file) 'no-byte-compile)) (should-not (file-exists-p dest-file)))) +(ert-deftest bytecomp--copy-tree () + (should (null (bytecomp--copy-tree nil))) + (let ((print-circle t)) + (let* ((x '(1 2 (3 4))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "((1 2 (3 4)) (1 2 (3 4)))"))) + (let* ((x '#1=(a #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(a #1#) #2=(a #2#))"))) + (let* ((x '#1=(#1# a)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(#1# a) #2=(#2# a))"))) + (let* ((x '((a . #1=(b)) #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(((a . #1=(b)) #1#) ((a . #2=(b)) #2#))"))) + (let* ((x '#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + (concat + "(" + "#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))" + " " + "#4=(a #5=(#4# b . #6=(#5# c . #4#)) (#6# d))" + ")")))))) ;; Local Variables: ;; no-byte-compile: t |