procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix cond jump table compilation (bug#42919)

Browse source 
This bug affected compilation of

 (cond ((member '(some list) variable) ...) ...)

While equal is symmetric, member is not; in the latter case the
arguments must be a variable and a constant list, in that order.

Reported by Ikumi Keita.

* lisp/emacs-lisp/bytecomp.el (byte-compile--cond-switch-prefix):
Don't treat equality and member predicates in the same way; only
the former are symmetric in their arguments.
* test/lisp/emacs-lisp/bytecomp-tests.el
(byte-opt-testsuite-arith-data): Add test cases.
This commit is contained in:
Mattias Engdegård 2020-08-19 14:59:29 +02:00
parent 362ca83a3b
commit 5fcb97dabd
2 changed files with 42 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -4172,40 +4172,44 @@ Return (TAIL VAR TEST CASES), where:
(switch-var nil)
(switch-test 'eq))
(while (pcase (car clauses)
(`((,fn ,expr1 ,expr2) . ,body)
(`((,(and fn (or 'eq 'eql 'equal)) ,expr1 ,expr2) . ,body)
(let* ((vars (byte-compile--cond-vars expr1 expr2))
(var (car vars))
(value (cdr vars)))
(and var (or (eq var switch-var) (not switch-var))
(cond
((memq fn '(eq eql equal))
(progn
(setq switch-var var)
(setq switch-test
(byte-compile--common-test switch-test fn))
(unless (member value keys)
(push value keys)
(push (cons (list value) (or body '(t))) cases))
t)
((and (memq fn '(memq memql member))
(listp value)
;; Require a non-empty body, since the member
;; function value depends on the switch
;; argument.
body)
(setq switch-var var)
(setq switch-test
(byte-compile--common-test
switch-test (cdr (assq fn '((memq . eq)
(memql . eql)
(member . equal))))))
(let ((vals nil))
(dolist (elem value)
(unless (funcall fn elem keys)
(push elem vals)))
(when vals
(setq keys (append vals keys))
(push (cons (nreverse vals) body) cases)))
t))))))
t))))
(`((,(and fn (or 'memq 'memql 'member)) ,var ,expr) . ,body)
(and (symbolp var)
(or (eq var switch-var) (not switch-var))
(macroexp-const-p expr)
;; Require a non-empty body, since the member
;; function value depends on the switch argument.
body
(let ((value (eval expr)))
(and (proper-list-p value)
(progn
(setq switch-var var)
(setq switch-test
(byte-compile--common-test
switch-test
(cdr (assq fn '((memq . eq)
(memql . eql)
(member . equal))))))
(let ((vals nil))
(dolist (elem value)
(unless (funcall fn elem keys)
(push elem vals)))
(when vals
(setq keys (append vals keys))
(push (cons (nreverse vals) body) cases)))
t))))))
(setq clauses (cdr clauses)))
;; Assume that a single switch is cheaper than two or more discrete
;; compare clauses. This could be tuned, possibly taking into

15
test/lisp/emacs-lisp/bytecomp-tests.el
View file

@ -347,7 +347,20 @@
((eq x 't) 99)
(t 999))))
'((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c)
(t c) (x "a") (x "c") (x c) (x d) (x e))))
(t c) (x "a") (x "c") (x c) (x d) (x e)))
(mapcar (lambda (x) (cond ((member '(a . b) x) 1)
((equal x '(c)) 2)))
'(((a . b)) a b (c) (d)))
(mapcar (lambda (x) (cond ((memq '(a . b) x) 1)
((equal x '(c)) 2)))
'(((a . b)) a b (c) (d)))
(mapcar (lambda (x) (cond ((member '(a b) x) 1)
((equal x '(c)) 2)))
'(((a b)) a b (c) (d)))
(mapcar (lambda (x) (cond ((memq '(a b) x) 1)
((equal x '(c)) 2)))
'(((a b)) a b (c) (d))))
"List of expression for test.
Each element will be executed by interpreter and with
bytecompiled code, and their results compared.")