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.

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index ab04c1bf4399b13bf66eb9c6913f745b73734cde..3a23543f6a76d88895fa1b28173cdcf3f79a8e74 100644 (file)
--- 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 0c151e3916918c3065f98c3ef06b6a1e9e57fbac..0f18a34578d30c74181f5c852f90a2fe3cd7f304 100644 (file)
--- 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.")