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

* lisp/emacs-lisp/pcase.el (pcase--split-pred): Handle memq pred.

Browse source 
Improve handling of the `member` tests generated from (or 'a 'b 'c).
This will expand

    (pcase EXP ((and (or 1 2 3) (guard (FOO))) EXP1) (1 EXP2) (6 EXP3))

to

    (cond ((memql '(3 2 1) EXP)
           (cond ((FOO) EXP1) ((eql EXP 1) EXP2)))
          ((eql EXP 6) EXP3))

rather than to

    (cond ((memql '(3 2 1) EXP)
           (cond ((FOO) EXP1) ((eql EXP 1) EXP2) ((eql EXP 6) EXP3)))
          ((eql EXP 1) EXP2)
          ((eql EXP 6) EXP3))
This commit is contained in:
Stefan Monnier 2021-01-27 18:51:09 -05:00
parent d168110a32
commit d93bca0197
1 changed files with 27 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

44
lisp/emacs-lisp/pcase.el
View file

@ -683,11 +683,6 @@ A and B can be one of:
;; and catch at least the easy cases such as (bug#14773).
(not (macroexp--fgrep (mapcar #'car vars) (cadr upat)))))
'(:pcase--succeed . :pcase--fail))
;; In case UPAT is of the form (pred (not PRED))
((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat))))
(let* ((test (cadr (cadr upat)))
(res (pcase--split-pred vars `(pred ,test) pat)))
(cons (cdr res) (car res))))
;; In case PAT is of the form (pred (not PRED))
((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
(let* ((test (cadr (cadr pat)))
@ -696,19 +691,34 @@ A and B can be one of:
((eq x :pcase--fail) :pcase--succeed)))))
(cons (funcall reverse (car res))
(funcall reverse (cdr res)))))
((and (eq 'pred (car upat))
(let ((otherpred
(cond ((eq 'pred (car-safe pat)) (cadr pat))
((not (eq 'quote (car-safe pat))) nil)
((consp (cadr pat)) #'consp)
((stringp (cadr pat)) #'stringp)
((vectorp (cadr pat)) #'vectorp)
((byte-code-function-p (cadr pat))
#'byte-code-function-p))))
(pcase--mutually-exclusive-p (cadr upat) otherpred)))
;; All the rest below presumes UPAT is of the form (pred ...).
((not (eq 'pred (car upat))) nil)
;; In case UPAT is of the form (pred (not PRED))
((eq 'not (car-safe (cadr upat)))
(let* ((test (cadr (cadr upat)))
(res (pcase--split-pred vars `(pred ,test) pat)))
(cons (cdr res) (car res))))
((let ((otherpred
(cond ((eq 'pred (car-safe pat)) (cadr pat))
((not (eq 'quote (car-safe pat))) nil)
((consp (cadr pat)) #'consp)
((stringp (cadr pat)) #'stringp)
((vectorp (cadr pat)) #'vectorp)
((byte-code-function-p (cadr pat))
#'byte-code-function-p))))
(pcase--mutually-exclusive-p (cadr upat) otherpred))
'(:pcase--fail . nil))
((and (eq 'pred (car upat))
(eq 'quote (car-safe pat))
;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
;; try and preserve the info we get from that memq test.
((and (eq 'pcase--flip (car-safe (cadr upat)))
(memq (cadr (cadr upat)) '(memq member memql))
(eq 'quote (car-safe (nth 2 (cadr upat))))
(eq 'quote (car-safe pat)))
(let ((set (cadr (nth 2 (cadr upat)))))
(if (member (cadr pat) set)
'(nil . :pcase--fail)
'(:pcase--fail . nil))))
((and (eq 'quote (car-safe pat))
(symbolp (cadr upat))
(or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
(get (cadr upat) 'side-effect-free)