[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 14a8152 3/4: Compile cond with heterogeneous tests
From: |
Mattias Engdegård |
Subject: |
[Emacs-diffs] master 14a8152 3/4: Compile cond with heterogeneous tests into switch (bug#36139) |
Date: |
Wed, 19 Jun 2019 05:24:50 -0400 (EDT) |
branch: master
commit 14a81524c27ab54850e0fda736e4ee0c92e447b5
Author: Mattias Engdegård <address@hidden>
Commit: Mattias Engdegård <address@hidden>
Compile cond with heterogeneous tests into switch (bug#36139)
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.
---
lisp/emacs-lisp/bytecomp.el | 29 +++++++++++++++++------------
test/lisp/emacs-lisp/bytecomp-tests.el | 25 ++++++++++++++++++++++++-
2 files changed, 41 insertions(+), 13 deletions(-)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index ab04c1b..3a23543 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -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)
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 0c151e3..0f18a34 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -311,7 +311,30 @@
(let ((x "a")) (cond ((equal x "a") 'correct)
((equal x "b") 'incorrect)
((equal x "a") 'incorrect)
- ((equal x "c") '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))
+ )
"List of expression for test.
Each element will be executed by interpreter and with
bytecompiled code, and their results compared.")