diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 46 | ||||
| -rw-r--r-- | lisp/emacs-lisp/radix-tree.el | 7 |
3 files changed, 43 insertions, 14 deletions
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 58517549454..fdbf95319ff 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -487,7 +487,7 @@ Errors during evaluation are caught and handled like nil." Returns nil if they are." (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) - (pcase-exhaustive a + (pcase a ((pred consp) (let ((a-length (proper-list-p a)) (b-length (proper-list-p b))) @@ -538,7 +538,7 @@ Returns nil if they are." for xi = (ert--explain-equal-rec ai bi) do (when xi (cl-return `(array-elt ,i ,xi))) finally (cl-assert (equal a b) t)))) - ((pred atom) + (_ (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 72ea1ba0188..bfd577c5d14 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -39,10 +39,10 @@ ;; - along these lines, provide patterns to match CL structs. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to subsequent cases (not sure what I meant by -;; this :-() +;; - provide a way to fallthrough to subsequent cases +;; (e.g. Like Racket's (=> ID). ;; - try and be more clever to reduce the size of the decision tree, and -;; to reduce the number of leaves that need to be turned into function: +;; to reduce the number of leaves that need to be turned into functions: ;; - first, do the tests shared by all remaining branches (it will have ;; to be performed anyway, so better do it first so it's shared). ;; - then choose the test that discriminates more (?). @@ -97,11 +97,15 @@ (declare-function get-edebug-spec "edebug" (symbol)) (declare-function edebug-match "edebug" (cursor specs)) +(defun pcase--get-macroexpander (s) + "Return the macroexpander for pcase pattern head S, or nil" + (get s 'pcase-macroexpander)) + (defun pcase--edebug-match-macro (cursor) (let (specs) (mapatoms (lambda (s) - (let ((m (get s 'pcase-macroexpander))) + (let ((m (pcase--get-macroexpander s))) (when (and m (get-edebug-spec m)) (push (cons (symbol-name s) (get-edebug-spec m)) specs))))) @@ -128,6 +132,7 @@ PATTERN matches. PATTERN can take one of the forms: If a SYMBOL is used twice in the same pattern the second occurrence becomes an `eq'uality test. (pred FUN) matches if FUN called on EXPVAL returns non-nil. + (pred (not FUN)) matches if FUN called on EXPVAL returns nil. (app FUN PAT) matches if FUN called on EXPVAL matches PAT. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let PAT EXPR) matches if EXPR matches PAT. @@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples." (let (more) ;; Collect all the extensions. (mapatoms (lambda (symbol) - (let ((me (get symbol 'pcase-macroexpander))) + (let ((me (pcase--get-macroexpander symbol))) (when me (push (cons symbol me) more))))) @@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'. ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) (t - (let* ((expander (get head 'pcase-macroexpander)) + (let* ((expander (pcase--get-macroexpander head)) (npat (if expander (apply expander (cdr pat))))) (if (null npat) (error (if expander @@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form: '(:pcase--succeed . nil)))) (defun pcase--split-pred (vars upat pat) + "Indicate the overlap or mutual-exclusion between UPAT and PAT. +More specifically retuns a pair (A . B) where A indicates whether PAT +can match when UPAT has matched, and B does the same for the case +where UPAT failed to match. +A and B can be one of: +- nil if we don't know +- `:pcase--fail' if UPAT match's result implies that PAT can't match +- `:pcase--succeed' if UPAT match's result implies that PAT matches" (let (test) (cond ((and (equal upat pat) @@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form: ;; 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))) + (res (pcase--split-pred vars upat `(pred ,test))) + (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail) + ((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)) @@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--funcall (fun arg vars) "Build a function call to FUN with arg ARG." - (if (symbolp fun) - `(,fun ,arg) + (cond + ((symbolp fun) `(,fun ,arg)) + ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars))) + (t (let* (;; `env' is an upper bound on the bindings we need. (env (mapcar (lambda (x) (list (car x) (cdr x))) (macroexp--fgrep vars fun))) @@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; Let's not replace `vars' in `fun' since it's ;; too difficult to do it right, instead just ;; let-bind `vars' around `fun'. - `(let* ,env ,call))))) + `(let* ,env ,call)))))) (defun pcase--eval (exp vars) "Build an expression that will evaluate EXP." diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index 6a483a6d498..0905ac608bb 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -198,9 +198,10 @@ If not found, return nil." (pcase-defmacro radix-tree-leaf (vpat) "Pattern which matches a radix-tree leaf. The pattern VPAT is matched against the leaf's carried value." - ;; FIXME: We'd like to use a negative pattern (not consp), but pcase - ;; doesn't support it. Using `atom' works but generates sub-optimal code. - `(or `(t . ,,vpat) (and (pred atom) ,vpat)))) + ;; We used to use `(pred atom)', but `pcase' doesn't understand that + ;; `atom' is equivalent to the negation of `consp' and hence generates + ;; suboptimal code. + `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat)))) (defun radix-tree-iter-subtrees (tree fun) "Apply FUN to every immediate subtree of radix TREE. |