mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-14 09:39:42 +00:00
Correctly eliminate duplicate cases in switch compilation
Fix code mistakes that prevented the correct elimination of duplicated cases when compiling a `cond' form to a switch bytecode, as in (cond ((eq x 'a) 1) ((eq x 'b) 2) ((eq x 'a) 3) ; should be elided ((eq x 'c) 4)) Sometimes, this caused the bytecode to use the wrong branch (bug#35770). * lisp/emacs-lisp/bytecomp.el (byte-compile-cond-vars): Return obj2 eval'ed. (byte-compile-cond-jump-table-info): Discard redundant condition. Use `obj2' as evaluated. Discard duplicated cases instead of failing the table generation. * test/lisp/emacs-lisp/bytecomp-tests.el (toplevel): Require subr-x. (byte-opt-testsuite-arith-data, bytecomp-test--switch-duplicates): Test.
This commit is contained in:
parent
457b024405
commit
68b374a62d
@ -4091,8 +4091,8 @@ that suppresses all warnings during execution of BODY."
|
||||
;; and the other is a constant expression whose value can be
|
||||
;; compared with `eq' (with `macroexp-const-p').
|
||||
(or
|
||||
(and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 obj2))
|
||||
(and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 obj1))))
|
||||
(and (symbolp obj1) (macroexp-const-p obj2) (cons obj1 (eval obj2)))
|
||||
(and (symbolp obj2) (macroexp-const-p obj1) (cons obj2 (eval obj1)))))
|
||||
|
||||
(defconst byte-compile--default-val (cons nil nil) "A unique object.")
|
||||
|
||||
@ -4121,12 +4121,11 @@ Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))"
|
||||
(unless prev-test
|
||||
(setq prev-test test))
|
||||
(if (and obj1 (memq test '(eq eql equal))
|
||||
(consp condition)
|
||||
(eq test prev-test)
|
||||
(eq obj1 prev-var)
|
||||
;; discard duplicate clauses
|
||||
(not (assq obj2 cases)))
|
||||
(push (list (if (consp obj2) (eval obj2) obj2) body) cases)
|
||||
(eq obj1 prev-var))
|
||||
;; discard duplicate clauses
|
||||
(unless (assoc obj2 cases test)
|
||||
(push (list obj2 body) cases))
|
||||
(if (and (macroexp-const-p condition) condition)
|
||||
(progn (push (list byte-compile--default-val
|
||||
(or body `(,condition)))
|
||||
|
@ -27,6 +27,7 @@
|
||||
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
(require 'subr-x)
|
||||
(require 'bytecomp)
|
||||
|
||||
;;; Code:
|
||||
@ -296,7 +297,21 @@
|
||||
((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))))
|
||||
"List of expression for test.
|
||||
Each element will be executed by interpreter and with
|
||||
bytecompiled code, and their results compared.")
|
||||
@ -613,6 +628,44 @@ literals (Bug#20852)."
|
||||
(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)))))
|
||||
|
||||
;; Local Variables:
|
||||
;; no-byte-compile: t
|
||||
;; End:
|
||||
|
Loading…
Reference in New Issue
Block a user