From: Stefan Monnier Date: Fri, 29 Oct 2010 01:05:38 +0000 (-0400) Subject: * lisp/emacs-lisp/pcase.el (pcase): New `string' and `guard' patterns. X-Git-Tag: emacs-pretest-24.0.90~104^2~275^2~438^2~45^2~370^2~16 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=dcc029e017acab959291f9d938234240ac3cea32;p=emacs.git * lisp/emacs-lisp/pcase.el (pcase): New `string' and `guard' patterns. (pcase-if): Add one minor optimization. (pcase-split-equal): Rename from pcase-split-eq. (pcase-split-member): Rename from pcase-split-memq. (pcase-u1): Add strings to the member optimization. Add `guard' variant of predicates. (pcase-q1): Add string patterns. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 66b98e8318a..fbbddf04b2e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2010-10-29 Stefan Monnier + + * emacs-lisp/pcase.el (pcase): New `string' and `guard' patterns. + (pcase-if): Add one minor optimization. + (pcase-split-equal): Rename from pcase-split-eq. + (pcase-split-member): Rename from pcase-split-memq. + (pcase-u1): Add strings to the member optimization. + Add `guard' variant of predicates. + (pcase-q1): Add string patterns. + 2010-10-28 Stefan Monnier * vc/log-edit.el (log-edit-rewrite-fixes): State its safety pred. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index b922e0b0233..90f2bf411b5 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -25,6 +25,16 @@ ;; ML-style pattern matching. ;; The entry points are autoloaded. +;; Todo: + +;; - provide ways to extend the set of primitives, with some kind of +;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) +;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). +;; But better would be if we could define new ways to match by having the +;; extension provide its own `pcase-split-' thingy. +;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to +;; generate a lex-style DFA to decide whether to run E1 or E2. + ;;; Code: (eval-when-compile (require 'cl)) @@ -48,10 +58,12 @@ UPatterns can take the following forms: (and UPAT...) matches if all the patterns match. `QPAT matches if the QPattern QPAT matches. (pred PRED) matches if PRED applied to the object returns non-nil. + (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. QPatterns can take the following forms: (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. ,UPAT matches if the UPattern UPAT matches. + STRING matches if the object is `equal' to STRING. ATOM matches if the object is `eq' to ATOM. QPatterns for vectors are not implemented yet. @@ -77,6 +89,8 @@ of the form (UPAT EXP)." (if (null bindings) body `(pcase ,(cadr (car bindings)) (,(caar bindings) (pcase-let* ,(cdr bindings) ,body)) + ;; FIXME: In many cases `dontcare' would be preferable, so maybe we + ;; should have `let' and `elet', like we have `case' and `ecase'. (t (error "Pattern match failure in `pcase-let'"))))) ;;;###autoload @@ -167,12 +181,19 @@ of the form (UPAT EXP)." (cond ((eq else :pcase-dontcare) then) ((eq (car-safe else) 'if) - `(cond (,test ,then) - (,(nth 1 else) ,(nth 2 else)) - (t ,@(nthcdr 3 else)))) + (if (equal test (nth 1 else)) + ;; Doing a test a second time: get rid of the redundancy. + ;; FIXME: ideally, this should never happen because the pcase-split-* + ;; functions should have eliminated such things, but pcase-split-member + ;; is imprecise, so in practice it does happen occasionally. + `(if ,test ,then ,@(nthcdr 3 else)) + `(cond (,test ,then) + (,(nth 1 else) ,(nth 2 else)) + (t ,@(nthcdr 3 else))))) ((eq (car-safe else) 'cond) `(cond (,test ,then) - ,@(cdr else))) + ;; Doing a test a second time: get rid of the redundancy, as above. + ,@(remove (assoc test else) (cdr else)))) (t `(if ,test ,then ,else)))) (defun pcase-upat (qpattern) @@ -276,7 +297,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; A QPattern but not for a cons, can only go the `else' side. ((eq (car-safe pat) '\`) (cons :pcase-fail nil)))) -(defun pcase-split-eq (elem pat) +(defun pcase-split-equal (elem pat) (cond ;; The same match will give the same result. ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) @@ -288,11 +309,11 @@ MATCH is the pattern that needs to be matched, of the form: ) (cons :pcase-fail nil)))) -(defun pcase-split-memq (elems pat) - ;; Based on pcase-split-eq. +(defun pcase-split-member (elems pat) + ;; Based on pcase-split-equal. (cond - ;; The same match will give the same result, but we don't know how - ;; to check it. + ;; 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)) ;; A match for one of the elements may succeed or fail. @@ -347,7 +368,8 @@ and otherwise defers to REST which is a list of branches of the form (if (and (eq (car alt) 'match) (eq var (cadr alt)) (let ((upat (cddr alt))) (and (eq (car-safe upat) '\`) - (or (integerp (cadr upat)) (symbolp (cadr upat)))))) + (or (integerp (cadr upat)) (symbolp (cadr upat)) + (stringp (cadr upat)))))) (push (cddr alt) simples) (push alt others)))) (cond @@ -380,17 +402,19 @@ and otherwise defers to REST which is a list of branches of the form ((memq upat '(t _)) (pcase-u1 matches code vars rest)) ((eq upat 'dontcare) :pcase-dontcare) ((functionp upat) (error "Feature removed, use (pred %s)" upat)) - ((eq (car-safe upat) 'pred) + ((memq (car-safe upat) '(guard pred)) (destructuring-bind (then-rest &rest else-rest) (pcase-split-rest sym (apply-partially 'pcase-split-pred upat) rest) - (pcase-if (if (symbolp (cadr upat)) + (pcase-if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) `(,(cadr upat) ,sym) (let* ((exp (cadr upat)) ;; `vs' is an upper bound on the vars we need. (vs (pcase-fgrep (mapcar #'car vars) exp)) - (call (if (functionp exp) - `(,exp ,sym) `(,@exp ,sym)))) + (call (cond + ((eq 'guard (car upat)) exp) + ((functionp exp) `(,exp ,sym)) + (t `(,@exp ,sym))))) (if (null vs) call ;; Let's not replace `vars' in `exp' since it's @@ -409,19 +433,22 @@ and otherwise defers to REST which is a list of branches of the form ((eq (car-safe upat) '\`) (pcase-q1 sym (cadr upat) matches code vars rest)) ((eq (car-safe upat) 'or) - (let ((all (> (length (cdr upat)) 1))) + (let ((all (> (length (cdr upat)) 1)) + (memq-fine t)) (when all (dolist (alt (cdr upat)) (unless (and (eq (car-safe alt) '\`) - (or (symbolp (cadr alt)) (integerp (cadr 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. (let ((elems (mapcar 'cadr (cdr upat)))) (destructuring-bind (then-rest &rest else-rest) (pcase-split-rest - sym (apply-partially 'pcase-split-memq elems) rest) - (pcase-if `(memq ,sym ',elems) + sym (apply-partially 'pcase-split-member elems) rest) + (pcase-if `(,(if memq-fine #'memq #'member) ,sym ',elems) (pcase-u1 matches code vars then-rest) (pcase-u else-rest)))) (pcase-u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars @@ -483,10 +510,10 @@ and if not, defers to REST which is a list of branches of the form ,@matches) code vars then-rest)) (pcase-u else-rest))))) - ((or (integerp qpat) (symbolp qpat)) + ((or (integerp qpat) (symbolp qpat) (stringp qpat)) (destructuring-bind (then-rest &rest else-rest) - (pcase-split-rest sym (apply-partially 'pcase-split-eq qpat) rest) - (pcase-if `(eq ,sym ',qpat) + (pcase-split-rest sym (apply-partially 'pcase-split-equal qpat) rest) + (pcase-if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat) (pcase-u1 matches code vars then-rest) (pcase-u else-rest)))) (t (error "Unkown QPattern %s" qpat))))