From 14a81524c27ab54850e0fda736e4ee0c92e447b5 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= Date: Wed, 22 May 2019 12:36:03 +0200 Subject: [PATCH] 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 ab04c1bf439..3a23543f6a7 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 0c151e39169..0f18a34578d 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.") -- 2.39.2