diff options
Diffstat (limited to 'lisp/emacs-lisp/pcase.el')
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 89 |
1 files changed, 56 insertions, 33 deletions
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 69834810d11..eb2c7f002e8 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -353,23 +353,34 @@ MATCH is the pattern that needs to be matched, of the form: (symbolp . numberp) (symbolp . consp) (symbolp . arrayp) + (symbolp . vectorp) (symbolp . stringp) (symbolp . byte-code-function-p) (integerp . consp) (integerp . arrayp) + (integerp . vectorp) (integerp . stringp) (integerp . byte-code-function-p) (numberp . consp) (numberp . arrayp) + (numberp . vectorp) (numberp . stringp) (numberp . byte-code-function-p) (consp . arrayp) + (consp . vectorp) (consp . stringp) (consp . byte-code-function-p) - (arrayp . stringp) (arrayp . byte-code-function-p) + (vectorp . byte-code-function-p) + (stringp . vectorp) (stringp . byte-code-function-p))) +(defun pcase--mutually-exclusive-p (pred1 pred2) + (or (member (cons pred1 pred2) + pcase-mutually-exclusive-predicates) + (member (cons pred2 pred1) + pcase-mutually-exclusive-predicates))) + (defun pcase--split-match (sym splitter match) (cond ((eq (car match) 'match) @@ -431,30 +442,28 @@ MATCH is the pattern that needs to be matched, of the form: (match ,symd . ,(pcase--upat (cdr qpat)))) :pcase--fail))) ;; A QPattern but not for a cons, can only go to the `else' side. - ((eq (car-safe pat) '\`) (cons :pcase--fail nil)) + ((eq (car-safe pat) '\`) '(:pcase--fail . nil)) ((and (eq (car-safe pat) 'pred) - (or (member (cons 'consp (cadr pat)) - pcase-mutually-exclusive-predicates) - (member (cons (cadr pat) 'consp) - pcase-mutually-exclusive-predicates))) - (cons :pcase--fail nil)))) + (pcase--mutually-exclusive-p #'consp (cadr pat))) + '(:pcase--fail . nil)))) (defun pcase--split-equal (elem pat) (cond ;; The same match will give the same result. ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) - (cons :pcase--succeed :pcase--fail)) + '(:pcase--succeed . :pcase--fail)) ;; A different match will fail if this one succeeds. ((and (eq (car-safe pat) '\`) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) - (cons :pcase--fail nil)) + '(:pcase--fail . nil)) ((and (eq (car-safe pat) 'pred) (symbolp (cadr pat)) - (get (cadr pat) 'side-effect-free) - (funcall (cadr pat) elem)) - (cons :pcase--succeed nil)))) + (get (cadr pat) 'side-effect-free)) + (if (funcall (cadr pat) elem) + '(:pcase--succeed . nil) + '(:pcase--fail . nil))))) (defun pcase--split-member (elems pat) ;; Based on pcase--split-equal. @@ -462,7 +471,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; The same match (or a match of membership in a superset) will ;; give the same result, but we don't know how to check it. ;; (??? - ;; (cons :pcase--succeed nil)) + ;; '(:pcase--succeed . nil)) ;; A match for one of the elements may succeed or fail. ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) nil) @@ -471,7 +480,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) - (cons :pcase--fail nil)) + '(:pcase--fail . nil)) ((and (eq (car-safe pat) 'pred) (symbolp (cadr pat)) (get (cadr pat) 'side-effect-free) @@ -479,21 +488,31 @@ MATCH is the pattern that needs to be matched, of the form: (dolist (elem elems) (unless (funcall p elem) (setq all nil))) all)) - (cons :pcase--succeed nil)))) + '(:pcase--succeed . nil)))) -(defun pcase--split-pred (upat pat) - ;; FIXME: For predicates like (pred (> a)), two such predicates may - ;; actually refer to different variables `a'. +(defun pcase--split-pred (vars upat pat) (let (test) (cond - ((equal upat pat) (cons :pcase--succeed :pcase--fail)) + ((and (equal upat pat) + ;; For predicates like (pred (> a)), two such predicates may + ;; actually refer to different variables `a'. + (or (and (eq 'pred (car upat)) (symbolp (cadr upat))) + ;; FIXME: `vars' gives us the environment in which `upat' will + ;; run, but we don't have the environment in which `pat' will + ;; run, so we can't do a reliable verification. But let's try + ;; and catch at least the easy cases such as (bug#14773). + (not (pcase--fgrep (mapcar #'car vars) (cadr upat))))) + '(:pcase--succeed . :pcase--fail)) ((and (eq 'pred (car upat)) - (eq 'pred (car-safe pat)) - (or (member (cons (cadr upat) (cadr pat)) - pcase-mutually-exclusive-predicates) - (member (cons (cadr pat) (cadr upat)) - pcase-mutually-exclusive-predicates))) - (cons :pcase--fail nil)) + (let ((otherpred + (cond ((eq 'pred (car-safe pat)) (cadr pat)) + ((not (eq '\` (car-safe pat))) nil) + ((consp (cadr pat)) #'consp) + ((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 '\` (car-safe pat)) (symbolp (cadr upat)) @@ -502,8 +521,8 @@ MATCH is the pattern that needs to be matched, of the form: (ignore-errors (setq test (list (funcall (cadr upat) (cadr pat)))))) (if (car test) - (cons nil :pcase--fail) - (cons :pcase--fail nil)))))) + '(nil . :pcase--fail) + '(:pcase--fail . nil)))))) (defun pcase--fgrep (vars sexp) "Check which of the symbols VARS appear in SEXP." @@ -588,7 +607,7 @@ Otherwise, it defers to REST which is a list of branches of the form (if (eq (car upat) 'pred) (pcase--mark-used sym)) (let* ((splitrest (pcase--split-rest - sym (lambda (pat) (pcase--split-pred upat pat)) rest)) + sym (lambda (pat) (pcase--split-pred vars upat pat)) rest)) (then-rest (car splitrest)) (else-rest (cdr splitrest))) (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) @@ -651,11 +670,15 @@ Otherwise, it defers to REST which is a list of branches of the form (memq-fine t)) (when all (dolist (alt (cdr upat)) - (unless (or (pcase--self-quoting-p alt) - (and (eq (car-safe alt) '\`) - (or (symbolp (cadr alt)) (integerp (cadr alt)) - (setq memq-fine nil) - (stringp (cadr alt))))) + (unless (if (pcase--self-quoting-p alt) + (progn + (unless (or (symbolp alt) (integerp alt)) + (setq memq-fine nil)) + t) + (and (eq (car-safe alt) '\`) + (or (symbolp (cadr alt)) (integerp (cadr alt)) + (setq memq-fine nil) + (stringp (cadr alt))))) (setq all nil)))) (if all ;; Use memq for (or `a `b `c `d) rather than a big tree. |