summaryrefslogtreecommitdiff
path: root/lisp/emacs-lisp/pcase.el
diff options
context:
space:
mode:
authorStefan Monnier <monnier@iro.umontreal.ca>2013-08-04 16:18:11 -0400
committerStefan Monnier <monnier@iro.umontreal.ca>2013-08-04 16:18:11 -0400
commit671d5c16547d16bef2efa056705bd35b5feacc29 (patch)
tree4bc2c3774ce9914f21508d0e2a83e25504dbc1db /lisp/emacs-lisp/pcase.el
parente443729d658ee2b9e0f55bbbb90241819bf516a6 (diff)
downloademacs-671d5c16547d16bef2efa056705bd35b5feacc29.tar.gz
emacs-671d5c16547d16bef2efa056705bd35b5feacc29.tar.bz2
emacs-671d5c16547d16bef2efa056705bd35b5feacc29.zip
* lisp/subr.el (macrop): New function.
(text-clone--maintaining): New var. (text-clone--maintain): Rename from text-clone-maintain. Use it instead of inhibit-modification-hooks. * lisp/emacs-lisp/nadvice.el (advice--normalize): For aliases to macros, use a proxy, so as handle autoloads and redefinitions of the target. (advice--defalias-fset, advice-remove): Use advice--symbol-function. * lisp/emacs-lisp/pcase.el (pcase-mutually-exclusive-predicates): Remove bogus (arrayp . stringp) pair. Add entries for `vectorp'. (pcase--mutually-exclusive-p): New function. (pcase--split-consp): Use it. (pcase--split-pred): Use it. Optimize the case where `pat' is a qpat mutually exclusive with the current predicate. * test/automated/advice-tests.el (advice-tests-nadvice): Test removal before definition. (advice-tests-macroaliases): New test. * lisp/emacs-lisp/edebug.el (edebug-lookup-function): Remove function. (edebug-macrop): Remove. Use `macrop' instead. * lisp/emacs-lisp/advice.el (ad-subr-p): Remove. Use `subrp' instead. (ad-macro-p): * lisp/eshell/esh-cmd.el (eshell-macrop): * lisp/apropos.el (apropos-macrop): Remove. Use `macrop' instead.
Diffstat (limited to 'lisp/emacs-lisp/pcase.el')
-rw-r--r--lisp/emacs-lisp/pcase.el31
1 files changed, 21 insertions, 10 deletions
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 50c92518b02..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)
@@ -433,10 +444,7 @@ MATCH is the pattern that needs to be matched, of the form:
;; A QPattern but not for a cons, can only go to the `else' side.
((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)))
+ (pcase--mutually-exclusive-p #'consp (cadr pat)))
'(:pcase--fail . nil))))
(defun pcase--split-equal (elem pat)
@@ -496,11 +504,14 @@ MATCH is the pattern that needs to be matched, of the form:
(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)))
+ (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))