mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 22:41:06 -08:00
Code Issues Projects Releases Wiki Activity

Compile cond with heterogeneous tests into switch (bug#36139)

Browse source 
Allow any mixture of `eq', `eql' and `equal', `memq', `memql' and
`member' in a switch-like `cond' to be compiled into a single switch.

* lisp/emacs-lisp/bytecomp.el (byte-compile--common-test): New.
(byte-compile-cond-jump-table-info): Use most specific common test.
* test/lisp/emacs-lisp/bytecomp-tests.el (byte-opt-testsuite-arith-data):
Add test cases for multi-value clause cond forms.
This commit is contained in:
Mattias Engdegård 2019-05-22 12:36:03 +02:00
parent b8c74742c0
commit 14a81524c2
2 changed files with 41 additions and 13 deletions
Download patch file Download diff file Expand all files Collapse all files

29
lisp/emacs-lisp/bytecomp.el
View file

@ -4132,6 +4132,12 @@ that suppresses all warnings during execution of BODY."
(defconst byte-compile--default-val (cons nil nil) "A unique object.")
(defun byte-compile--common-test (test-1 test-2)
"Most specific common test of `eq', `eql' and `equal'"
(cond ((or (eq test-1 'equal) (eq test-2 'equal)) 'equal)
((or (eq test-1 'eql) (eq test-2 'eql)) 'eql)
(t 'eq)))
(defun byte-compile-cond-jump-table-info (clauses)
"If CLAUSES is a `cond' form where:
The condition for each clause is of the form (TEST VAR VALUE).
@ -4143,7 +4149,8 @@ Return a list of the form ((TEST . VAR) ((VALUES BODY) ...))"
(let ((cases '())
(ok t)
(all-keys nil)
prev-var prev-test)
(prev-test 'eq)
prev-var)
(and (catch 'break
(dolist (clause (cdr clauses) ok)
(let* ((condition (car clause))
@ -4152,15 +4159,13 @@ Return a list of the form ((TEST . VAR) ((VALUES BODY) ...))"
(byte-compile-cond-vars (cadr condition) (cl-caddr condition))))
(obj1 (car-safe vars))
(obj2 (cdr-safe vars))
(body (cdr-safe clause))
equality)
(body (cdr-safe clause)))
(unless prev-var
(setq prev-var obj1))
(cond
((and obj1 (memq test '(eq eql equal))
(eq obj1 prev-var)
(or (not prev-test) (eq test prev-test)))
(setq prev-test test)
(eq obj1 prev-var))
(setq prev-test (byte-compile--common-test prev-test test))
;; Discard values already tested for.
(unless (member obj2 all-keys)
(push obj2 all-keys)
@ -4171,12 +4176,12 @@ Return a list of the form ((TEST . VAR) ((VALUES BODY) ...))"
(listp obj2)
;; Require a non-empty body, since the member function
;; value depends on the switch argument.
body
(setq equality (cdr (assq test '((memq . eq)
(memql . eql)
(member . equal)))))
(or (not prev-test) (eq equality prev-test)))
(setq prev-test equality)
body)
(setq prev-test
(byte-compile--common-test
prev-test (cdr (assq test '((memq . eq)
(memql . eql)
(member . equal))))))
(let ((vals nil))
;; Discard values already tested for.
(dolist (elem obj2)