Commit 2b968ea6 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* lisp/emacs-lisp/pcase.el: Allow (F . ARGS) in `app' patterns.

(pcase--funcall, pcase--eval): New functions.
(pcase--u1): Use them for guard, pred, let, and app.
(\`): Use the new feature to generate better code for vector patterns.
parent 7fbd780a
2014-09-22 Stefan Monnier <monnier@iro.umontreal.ca>
 
* emacs-lisp/pcase.el: Allow (F . ARGS) in `app' patterns.
(pcase--funcall, pcase--eval): New functions.
(pcase--u1): Use them for guard, pred, let, and app.
(\`): Use the new feature to generate better code for vector patterns.
* emacs-lisp/pcase.el: Use pcase-defmacro to handle backquote.
(pcase--upat): Remove.
(pcase--macroexpand): Don't hardcode handling of `.
......
......@@ -104,17 +104,13 @@ UPatterns can take the following forms:
(and UPAT...) matches if all the patterns match.
'VAL matches if the object is `equal' to VAL
`QPAT matches if the QPattern QPAT matches.
(pred PRED) matches if PRED applied to the object returns non-nil.
(pred FUN) matches if FUN applied to the object returns non-nil.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
(let UPAT EXP) matches if EXP matches UPAT.
(app FUN UPAT) matches if FUN applied to the object matches UPAT.
If a SYMBOL is used twice in the same pattern (i.e. the pattern is
\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
FUN can be either of the form (lambda ARGS BODY) or a symbol.
It has to obey the rule that if (FUN X) returns V then calling it again will
return the same V again (so that multiple (FUN X) can be consolidated).
QPatterns can take the following forms:
(QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
[QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match
......@@ -123,12 +119,14 @@ QPatterns can take the following forms:
STRING matches if the object is `equal' to STRING.
ATOM matches if the object is `eq' to ATOM.
PRED can take the form
FUNCTION in which case it gets called with one argument.
FUN can take the form
SYMBOL or (lambda ARGS BODY) in which case it's called with one argument.
(F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
which is the value being matched.
A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
PRED patterns can refer to variables bound earlier in the pattern.
So a FUN of the form SYMBOL is equivalent to one of the form (FUN).
FUN can refer to variables bound earlier in the pattern.
FUN is assumed to be pure, i.e. it can be dropped if its result is not used,
and two identical calls can be merged into one.
E.g. you can match pairs where the cdr is larger than the car with a pattern
like `(,a . ,(pred (< a))) or, with more checks:
`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
......@@ -600,6 +598,40 @@ MATCH is the pattern that needs to be matched, of the form:
(declare (debug (sexp body)))
`(,fun ,arg2 ,arg1))
(defun pcase--funcall (fun arg vars)
"Build a function call to FUN with arg ARG."
(if (symbolp fun)
`(,fun ,arg)
(let* (;; `vs' is an upper bound on the vars we need.
(vs (pcase--fgrep (mapcar #'car vars) fun))
(env (mapcar (lambda (var)
(list var (cdr (assq var vars))))
vs))
(call (progn
(when (memq arg vs)
;; `arg' is shadowed by `env'.
(let ((newsym (make-symbol "x")))
(push (list newsym arg) env)
(setq arg newsym)))
(if (functionp fun)
`(funcall #',fun ,arg)
`(,@fun ,arg)))))
(if (null vs)
call
;; 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)))))
(defun pcase--eval (exp vars)
"Build an expression that will evaluate EXP."
(let* ((found (assq exp vars)))
(if found (cdr found)
(let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
(env (mapcar (lambda (v) (list v (cdr (assq v vars))))
vs)))
(if env (macroexp-let* env exp) exp)))))
;; It's very tempting to use `pcase' below, tho obviously, it'd create
;; bootstrapping problems.
(defun pcase--u1 (matches code vars rest)
......@@ -674,30 +706,9 @@ Otherwise, it defers to REST which is a list of branches of the form
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)))
`(,(cadr upat) ,sym)
(let* ((exp (cadr upat))
;; `vs' is an upper bound on the vars we need.
(vs (pcase--fgrep (mapcar #'car vars) exp))
(env (mapcar (lambda (var)
(list var (cdr (assq var vars))))
vs))
(call (if (eq 'guard (car upat))
exp
(when (memq sym vs)
;; `sym' is shadowed by `env'.
(let ((newsym (make-symbol "x")))
(push (list newsym sym) env)
(setq sym newsym)))
(if (functionp exp)
`(funcall #',exp ,sym)
`(,@exp ,sym)))))
(if (null vs)
call
;; Let's not replace `vars' in `exp' since it's
;; too difficult to do it right, instead just
;; let-bind `vars' around `exp'.
`(let* ,env ,call))))
(pcase--if (if (eq (car upat) 'pred)
(pcase--funcall (cadr upat) sym vars)
(pcase--eval (cadr upat) vars))
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
((symbolp upat)
......@@ -714,13 +725,7 @@ Otherwise, it defers to REST which is a list of branches of the form
;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
(macroexp-let2
macroexp-copyable-p sym
(let* ((exp (nth 2 upat))
(found (assq exp vars)))
(if found (cdr found)
(let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
(env (mapcar (lambda (v) (list v (cdr (assq v vars))))
vs)))
(if env (macroexp-let* env exp) exp))))
(pcase--eval (nth 2 upat) vars)
(pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
code vars rest)))
((eq (car-safe upat) 'app)
......@@ -737,14 +742,7 @@ Otherwise, it defers to REST which is a list of branches of the form
(if (not (get nsym 'pcase-used))
body
(macroexp-let*
`((,nsym
,(if (symbolp fun)
`(,fun ,sym)
(let* ((vs (pcase--fgrep (mapcar #'car vars) fun))
(env (mapcar (lambda (v) (list v (cdr (assq v vars))))
vs))
(call `(funcall #',fun ,sym)))
(if env (macroexp-let* env call) call)))))
`((,nsym ,(pcase--funcall fun sym vars)))
body))))
((eq (car-safe upat) 'quote)
(pcase--mark-used sym)
......@@ -794,7 +792,7 @@ Otherwise, it defers to REST which is a list of branches of the form
(app length ,(length qpat))
,@(let ((upats nil))
(dotimes (i (length qpat))
(push `(app (lambda (v) (aref v ,i)) ,(list '\` (aref qpat i)))
(push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
upats))
(nreverse upats))))
((consp qpat)
......
......@@ -58,6 +58,8 @@
(should-not (pcase-tests-grep 'memq exp))
(should-not (pcase-tests-grep 'member exp))))
(ert-deftest pcase-tests-vectors ()
(should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3)))
;; Local Variables:
;; no-byte-compile: t
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment