[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] trunk r117919: Add pcase-defmacro, as well as `quote' and
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] trunk r117919: Add pcase-defmacro, as well as `quote' and `app' patterns. |
|
Date: |
Mon, 22 Sep 2014 18:22:17 +0000 |
|
User-agent: |
Bazaar (2.6b2) |
------------------------------------------------------------
revno: 117919 [merge]
revision-id: address@hidden
parent: address@hidden
parent: address@hidden
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Mon 2014-09-22 14:22:02 -0400
message:
Add pcase-defmacro, as well as `quote' and `app' patterns.
* loadup.el: Increase max-lisp-eval-depth when macroexpanding macroexp.
* 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 `.
(pcase--split-consp, pcase--split-vector): Remove.
(pcase--split-equal): Disregard ` since it's expanded away.
(pcase--split-member): Optimize for quote rather than for `.
(pcase--split-pred): Optimize for quote rather than for `.
(pcase--u1): Remove handling of ` (and of `or' and `and').
Quote non-selfquoting values when passing them to `eq'.
Drop `app's let-binding if the variable is not used.
(pcase--q1): Remove.
(`): Define as a pattern macro.
* emacs-lisp/pcase.el (pcase--match): New smart-constructor function.
(pcase--expand pcase--q1, pcase--app-subst-match): Use it.
(pcase--macroexpand): Handle self-quoting patterns here, expand them to
quote patterns.
(pcase--split-match): Don't hoist or/and here any more.
(pcase--split-equal): Optimize quote patterns as well as ` patterns.
(pcase--flip): New helper macro.
(pcase--u1): Optimize the memq case directly.
Don't handle neither self-quoting nor and/or patterns any more.
* emacs-lisp/pcase.el (pcase-defmacro): New macro.
(pcase--macroexpand): New function.
(pcase--expand): Use it.
* emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest):
New optimization functions.
(pcase--u1): Add support for `quote' and `app'.
(pcase): Document them in the docstring.
added:
test/automated/pcase-tests.el pcasetests.el-20140922142801-z0omr2t1z10lq9r3-1
modified:
etc/NEWS news-20100311060928-aoit31wvzf25yr1z-1
lisp/ChangeLog changelog-20091113204419-o5vbwnq5f7feedwu-1432
lisp/emacs-lisp/pcase.el pcase.el-20100810123717-8zwve3391p2ywm1h-1
lisp/loadup.el loadup.el-20091113204419-o5vbwnq5f7feedwu-49
=== modified file 'etc/NEWS'
--- a/etc/NEWS 2014-09-15 00:20:21 +0000
+++ b/etc/NEWS 2014-09-22 15:04:12 +0000
@@ -102,6 +102,10 @@
* Changes in Specialized Modes and Packages in Emacs 24.5
+** pcase
+*** New UPatterns `quote' and `app'.
+*** New UPatterns can be defined with `pcase-defmacro'.
+
** Lisp mode
*** Strings after `:documentation' are highlighted as docstrings.
=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog 2014-09-22 14:10:53 +0000
+++ b/lisp/ChangeLog 2014-09-22 18:22:02 +0000
@@ -1,5 +1,42 @@
2014-09-22 Stefan Monnier <address@hidden>
+ Add pcase-defmacro, as well as `quote' and `app' patterns.
+ * loadup.el: Increase max-lisp-eval-depth when macroexpanding macroexp.
+ * 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 `.
+ (pcase--split-consp, pcase--split-vector): Remove.
+ (pcase--split-equal): Disregard ` since it's expanded away.
+ (pcase--split-member): Optimize for quote rather than for `.
+ (pcase--split-pred): Optimize for quote rather than for `.
+ (pcase--u1): Remove handling of ` (and of `or' and `and').
+ Quote non-selfquoting values when passing them to `eq'.
+ Drop `app's let-binding if the variable is not used.
+ (pcase--q1): Remove.
+ (`): Define as a pattern macro.
+ * emacs-lisp/pcase.el (pcase--match): New smart-constructor function.
+ (pcase--expand pcase--q1, pcase--app-subst-match): Use it.
+ (pcase--macroexpand): Handle self-quoting patterns here, expand them to
+ quote patterns.
+ (pcase--split-match): Don't hoist or/and here any more.
+ (pcase--split-equal): Optimize quote patterns as well as ` patterns.
+ (pcase--flip): New helper macro.
+ (pcase--u1): Optimize the memq case directly.
+ Don't handle neither self-quoting nor and/or patterns any more.
+ * emacs-lisp/pcase.el (pcase-defmacro): New macro.
+ (pcase--macroexpand): New function.
+ (pcase--expand): Use it.
+ * emacs-lisp/pcase.el (pcase--app-subst-match, pcase--app-subst-rest):
+ New optimization functions.
+ (pcase--u1): Add support for `quote' and `app'.
+ (pcase): Document them in the docstring.
+
+2014-09-22 Stefan Monnier <address@hidden>
+
Use lexical-bindin in Ibuffer.
* ibuffer.el (ibuffer-do-toggle-read-only): `arg' is unused.
(ibuffer-compile-format): Simplify.
=== modified file 'lisp/emacs-lisp/pcase.el'
--- a/lisp/emacs-lisp/pcase.el 2014-09-13 16:30:21 +0000
+++ b/lisp/emacs-lisp/pcase.el 2014-09-22 18:05:22 +0000
@@ -102,10 +102,12 @@
SYMBOL matches anything and binds it to SYMBOL.
(or UPAT...) matches if any of the patterns matches.
(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.
@@ -117,12 +119,14 @@
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 ARG1 .. ARGN) in which case it gets called with an N+1'th 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))))"
@@ -157,6 +161,7 @@
(let* ((x (make-symbol "x"))
(pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
(pcase--expand
+ ;; FIXME: Could we add the FILE:LINE data in the error message?
exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
(defun pcase--let* (bindings body)
@@ -277,7 +282,7 @@
(main
(pcase--u
(mapcar (lambda (case)
- `((match ,val . ,(car case))
+ `(,(pcase--match val (pcase--macroexpand (car case)))
,(lambda (vars)
(unless (memq case used-cases)
;; Keep track of the cases that are used.
@@ -296,6 +301,45 @@
(message "Redundant pcase pattern: %S" (car case))))
(macroexp-let* defs main))))
+(defun pcase--macroexpand (pat)
+ "Expands all macro-patterns in PAT."
+ (let ((head (car-safe pat)))
+ (cond
+ ((null head)
+ (if (pcase--self-quoting-p pat) `',pat pat))
+ ((memq head '(pred guard quote)) pat)
+ ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
+ ((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))
+ (npat (if expander (apply expander (cdr pat)))))
+ (if (null npat)
+ (error (if expander
+ "Unexpandable %s pattern: %S"
+ "Unknown %s pattern: %S")
+ head pat)
+ (pcase--macroexpand npat)))))))
+
+;;;###autoload
+(defmacro pcase-defmacro (name args &rest body)
+ "Define a pcase UPattern macro."
+ (declare (indent 2) (debug (def-name sexp def-body)) (doc-string 3))
+ `(put ',name 'pcase-macroexpander
+ (lambda ,args ,@body)))
+
+(defun pcase--match (val upat)
+ "Build a MATCH structure, hoisting all `or's and `and's outside."
+ (cond
+ ;; Hoist or/and patterns into or/and matches.
+ ((memq (car-safe upat) '(or and))
+ `(,(car upat)
+ ,@(mapcar (lambda (upat)
+ (pcase--match val upat))
+ (cdr upat))))
+ (t
+ `(match ,val . ,upat))))
+
(defun pcase-codegen (code vars)
;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
@@ -319,11 +363,6 @@
((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
(t (macroexp-if test then else))))
-(defun pcase--upat (qpattern)
- (cond
- ((eq (car-safe qpattern) '\,) (cadr qpattern))
- (t (list '\` qpattern))))
-
;; Note about MATCH:
;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
;; check, we want to turn all the similar patterns into ones of the form
@@ -399,17 +438,8 @@
((eq (car match) 'match)
(if (not (eq sym (cadr match)))
(cons match match)
- (let ((pat (cddr match)))
- (cond
- ;; Hoist `or' and `and' patterns to `or' and `and' matches.
- ((memq (car-safe pat) '(or and))
- (pcase--split-match sym splitter
- (cons (car pat)
- (mapcar (lambda (alt)
- `(match ,sym . ,alt))
- (cdr pat)))))
- (t (let ((res (funcall splitter (cddr match))))
- (cons (or (car res) match) (or (cdr res) match))))))))
+ (let ((res (funcall splitter (cddr match))))
+ (cons (or (car res) match) (or (cdr res) match)))))
((memq (car match) '(or and))
(let ((then-alts '())
(else-alts '())
@@ -446,45 +476,13 @@
(push (cons (cdr split) code&vars) else-rest))))
(cons (nreverse then-rest) (nreverse else-rest))))
-(defun pcase--split-consp (syma symd pat)
- (cond
- ;; A QPattern for a cons, can only go the `then' side.
- ((and (eq (car-safe pat) '\`) (consp (cadr pat)))
- (let ((qpat (cadr pat)))
- (cons `(and (match ,syma . ,(pcase--upat (car qpat)))
- (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) '\`) '(:pcase--fail . nil))
- ((and (eq (car-safe pat) 'pred)
- (pcase--mutually-exclusive-p #'consp (cadr pat)))
- '(:pcase--fail . nil))))
-
-(defun pcase--split-vector (syms pat)
- (cond
- ;; A QPattern for a vector of same length.
- ((and (eq (car-safe pat) '\`)
- (vectorp (cadr pat))
- (= (length syms) (length (cadr pat))))
- (let ((qpat (cadr pat)))
- (cons `(and ,@(mapcar (lambda (s)
- `(match ,(car s) .
- ,(pcase--upat (aref qpat (cdr s)))))
- syms))
- :pcase--fail)))
- ;; Other QPatterns go to the `else' side.
- ((eq (car-safe pat) '\`) '(:pcase--fail . nil))
- ((and (eq (car-safe pat) 'pred)
- (pcase--mutually-exclusive-p #'vectorp (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))
+ ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem))
'(:pcase--succeed . :pcase--fail))
;; A different match will fail if this one succeeds.
- ((and (eq (car-safe pat) '\`)
+ ((and (eq (car-safe pat) 'quote)
;; (or (integerp (cadr pat)) (symbolp (cadr pat))
;; (consp (cadr pat)))
)
@@ -498,6 +496,7 @@
'(:pcase--fail . nil))))))
(defun pcase--split-member (elems pat)
+ ;; FIXME: The new pred-based member code doesn't do these optimizations!
;; Based on pcase--split-equal.
(cond
;; The same match (or a match of membership in a superset) will
@@ -505,10 +504,10 @@
;; (???
;; '(:pcase--succeed . nil))
;; A match for one of the elements may succeed or fail.
- ((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
+ ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems))
nil)
;; A different match will fail if this one succeeds.
- ((and (eq (car-safe pat) '\`)
+ ((and (eq (car-safe pat) 'quote)
;; (or (integerp (cadr pat)) (symbolp (cadr pat))
;; (consp (cadr pat)))
)
@@ -539,7 +538,7 @@
((and (eq 'pred (car upat))
(let ((otherpred
(cond ((eq 'pred (car-safe pat)) (cadr pat))
- ((not (eq '\` (car-safe pat))) nil)
+ ((not (eq 'quote (car-safe pat))) nil)
((consp (cadr pat)) #'consp)
((vectorp (cadr pat)) #'vectorp)
((byte-code-function-p (cadr pat))
@@ -547,7 +546,7 @@
(pcase--mutually-exclusive-p (cadr upat) otherpred)))
'(:pcase--fail . nil))
((and (eq 'pred (car upat))
- (eq '\` (car-safe pat))
+ (eq 'quote (car-safe pat))
(symbolp (cadr upat))
(or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
(get (cadr upat) 'side-effect-free)
@@ -569,10 +568,70 @@
(defun pcase--self-quoting-p (upat)
(or (keywordp upat) (numberp upat) (stringp upat)))
+(defun pcase--app-subst-match (match sym fun nsym)
+ (cond
+ ((eq (car match) 'match)
+ (if (and (eq sym (cadr match))
+ (eq 'app (car-safe (cddr match)))
+ (equal fun (nth 1 (cddr match))))
+ (pcase--match nsym (nth 2 (cddr match)))
+ match))
+ ((memq (car match) '(or and))
+ `(,(car match)
+ ,@(mapcar (lambda (match)
+ (pcase--app-subst-match match sym fun nsym))
+ (cdr match))))
+ (t (error "Uknown MATCH %s" match))))
+
+(defun pcase--app-subst-rest (rest sym fun nsym)
+ (mapcar (lambda (branch)
+ `(,(pcase--app-subst-match (car branch) sym fun nsym)
+ ,@(cdr branch)))
+ rest))
+
(defsubst pcase--mark-used (sym)
;; Exceptionally, `sym' may be a constant expression rather than a symbol.
(if (symbolp sym) (put sym 'pcase-used t)))
+(defmacro pcase--flip (fun arg1 arg2)
+ "Helper function, used internally to avoid (funcall (lambda ...) ...)."
+ (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)
@@ -594,22 +653,26 @@
((eq 'or (caar matches))
(let* ((alts (cdar matches))
(var (if (eq (caar alts) 'match) (cadr (car alts))))
- (simples '()) (others '()))
+ (simples '()) (others '()) (memq-ok t))
(when var
(dolist (alt alts)
(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))
- (stringp (cadr upat))))))
- (push (cddr alt) simples)
+ (eq (car-safe upat) 'quote)))
+ (let ((val (cadr (cddr alt))))
+ (unless (or (integerp val) (symbolp val))
+ (setq memq-ok nil))
+ (push (cadr (cddr alt)) simples))
(push alt others))))
(cond
((null alts) (error "Please avoid it") (pcase--u rest))
+ ;; Yes, we can use `memq' (or `member')!
((> (length simples) 1)
- ;; De-hoist the `or' MATCH into an `or' pattern that will be
- ;; turned into a `memq' below.
- (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
+ (pcase--u1 (cons `(match ,var
+ . (pred (pcase--flip
+ ,(if memq-ok #'memq #'member)
+ ',simples)))
+ (cdr matches))
code vars
(if (null others) rest
(cons (cons
@@ -643,35 +706,11 @@
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))))
- ((pcase--self-quoting-p upat)
- (pcase--mark-used sym)
- (pcase--q1 sym upat matches code vars rest))
((symbolp upat)
(pcase--mark-used sym)
(if (not (assq upat vars))
@@ -686,57 +725,41 @@
;; (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--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
+ (pcase--eval (nth 2 upat) vars)
+ (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
code vars rest)))
- ((eq (car-safe upat) '\`)
- (pcase--mark-used sym)
- (pcase--q1 sym (cadr upat) matches code vars rest))
- ((eq (car-safe upat) 'or)
- (let ((all (> (length (cdr upat)) 1))
- (memq-fine t))
- (when all
- (dolist (alt (cdr upat))
- (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.
- (let* ((elems (mapcar (lambda (x) (if (consp x) (cadr x) x))
- (cdr upat)))
- (splitrest
- (pcase--split-rest
- sym (lambda (pat) (pcase--split-member elems pat))
rest))
- (then-rest (car splitrest))
- (else-rest (cdr splitrest)))
- (pcase--mark-used sym)
- (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
- (append (mapcar (lambda (upat)
- `((and (match ,sym . ,upat) ,@matches)
- ,code ,@vars))
- (cddr upat))
- rest)))))
- ((eq (car-safe upat) 'and)
- (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat))
- (cdr upat))
- matches)
- code vars rest))
+ ((eq (car-safe upat) 'app)
+ ;; A upat of the form (app FUN UPAT)
+ (pcase--mark-used sym)
+ (let* ((fun (nth 1 upat))
+ (nsym (make-symbol "x"))
+ (body
+ ;; We don't change `matches' to reuse the newly computed value,
+ ;; because we assume there shouldn't be such redundancy in
there.
+ (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches)
+ code vars
+ (pcase--app-subst-rest rest sym fun nsym))))
+ (if (not (get nsym 'pcase-used))
+ body
+ (macroexp-let*
+ `((,nsym ,(pcase--funcall fun sym vars)))
+ body))))
+ ((eq (car-safe upat) 'quote)
+ (pcase--mark-used sym)
+ (let* ((val (cadr upat))
+ (splitrest (pcase--split-rest
+ sym (lambda (pat) (pcase--split-equal val pat))
rest))
+ (then-rest (car splitrest))
+ (else-rest (cdr splitrest)))
+ (pcase--if (cond
+ ((null val) `(null ,sym))
+ ((or (integerp val) (symbolp val))
+ (if (pcase--self-quoting-p val)
+ `(eq ,sym ,val)
+ `(eq ,sym ',val)))
+ (t `(equal ,sym ',val)))
+ (pcase--u1 matches code vars then-rest)
+ (pcase--u else-rest))))
((eq (car-safe upat) 'not)
;; FIXME: The implementation below is naive and results in
;; inefficient code.
@@ -758,79 +781,25 @@
(pcase--u rest))
vars
(list `((and . ,matches) ,code . ,vars))))
- (t (error "Unknown upattern `%s'" upat)))))
- (t (error "Incorrect MATCH %s" (car matches)))))
+ (t (error "Unknown internal pattern `%S'" upat)))))
+ (t (error "Incorrect MATCH %S" (car matches)))))
-(defun pcase--q1 (sym qpat matches code vars rest)
- "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
-Otherwise, it defers to REST which is a list of branches of the form
-\(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
+(pcase-defmacro \` (qpat)
(cond
- ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
- ((floatp qpat) (error "Floating point patterns not supported"))
+ ((eq (car-safe qpat) '\,) (cadr qpat))
((vectorp qpat)
- (let* ((len (length qpat))
- (syms (mapcar (lambda (i) (cons (make-symbol (format "xaref%s" i))
i))
- (number-sequence 0 (1- len))))
- (splitrest (pcase--split-rest
- sym
- (lambda (pat) (pcase--split-vector syms pat))
- rest))
- (then-rest (car splitrest))
- (else-rest (cdr splitrest))
- (then-body (pcase--u1
- `(,@(mapcar (lambda (s)
- `(match ,(car s) .
- ,(pcase--upat (aref qpat (cdr
s)))))
- syms)
- ,@matches)
- code vars then-rest)))
- (pcase--if
- `(and (vectorp ,sym) (= (length ,sym) ,len))
- (macroexp-let* (delq nil (mapcar (lambda (s)
- (and (get (car s) 'pcase-used)
- `(,(car s) (aref ,sym ,(cdr
s)))))
- syms))
- then-body)
- (pcase--u else-rest))))
+ `(and (pred vectorp)
+ (app length ,(length qpat))
+ ,@(let ((upats nil))
+ (dotimes (i (length qpat))
+ (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
+ upats))
+ (nreverse upats))))
((consp qpat)
- (let* ((syma (make-symbol "xcar"))
- (symd (make-symbol "xcdr"))
- (splitrest (pcase--split-rest
- sym
- (lambda (pat) (pcase--split-consp syma symd pat))
- rest))
- (then-rest (car splitrest))
- (else-rest (cdr splitrest))
- (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
- (match ,symd . ,(pcase--upat (cdr qpat)))
- ,@matches)
- code vars then-rest)))
- (pcase--if
- `(consp ,sym)
- ;; We want to be careful to only add bindings that are used.
- ;; The byte-compiler could do that for us, but it would have to pay
- ;; attention to the `consp' test in order to figure out that car/cdr
- ;; can't signal errors and our byte-compiler is not that clever.
- ;; FIXME: Some of those let bindings occur too early (they are used in
- ;; `then-body', but only within some sub-branch).
- (macroexp-let*
- `(,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
- ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
- then-body)
- (pcase--u else-rest))))
- ((or (integerp qpat) (symbolp qpat) (stringp qpat))
- (let* ((splitrest (pcase--split-rest
- sym (lambda (pat) (pcase--split-equal qpat pat)) rest))
- (then-rest (car splitrest))
- (else-rest (cdr splitrest)))
- (pcase--if (cond
- ((stringp qpat) `(equal ,sym ,qpat))
- ((null qpat) `(null ,sym))
- (t `(eq ,sym ',qpat)))
- (pcase--u1 matches code vars then-rest)
- (pcase--u else-rest))))
- (t (error "Unknown QPattern %s" qpat))))
+ `(and (pred consp)
+ (app car ,(list '\` (car qpat)))
+ (app cdr ,(list '\` (cdr qpat)))))
+ ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat)))
(provide 'pcase)
=== modified file 'lisp/loadup.el'
--- a/lisp/loadup.el 2014-06-01 02:36:40 +0000
+++ b/lisp/loadup.el 2014-09-22 18:17:27 +0000
@@ -119,7 +119,8 @@
(let ((macroexp--pending-eager-loads '(skip)))
(load "emacs-lisp/pcase"))
;; Re-load macroexp so as to eagerly macro-expand its uses of pcase.
- (load "emacs-lisp/macroexp"))
+ (let ((max-lisp-eval-depth (* 2 max-lisp-eval-depth)))
+ (load "emacs-lisp/macroexp")))
(load "cus-face")
(load "faces") ; after here, `defface' may be used.
=== added file 'test/automated/pcase-tests.el'
--- a/test/automated/pcase-tests.el 1970-01-01 00:00:00 +0000
+++ b/test/automated/pcase-tests.el 2014-09-22 18:05:22 +0000
@@ -0,0 +1,68 @@
+;;; pcase-tests.el --- Test suite for pcase macro.
+
+;; Copyright (C) 2012-2014 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+(require 'cl-lib)
+
+(ert-deftest pcase-tests-base ()
+ "Test pcase code."
+ (should (equal (pcase '(1 . 2) ((app car '2) 6) ((app car '1) 5)) 5)))
+
+(pcase-defmacro pcase-tests-plus (pat n)
+ `(app (lambda (v) (- v ,n)) ,pat))
+
+(ert-deftest pcase-tests-macro ()
+ (should (equal (pcase 5 ((pcase-tests-plus x 3) x)) 2)))
+
+(defun pcase-tests-grep (fname exp)
+ (when (consp exp)
+ (or (eq fname (car exp))
+ (cl-some (lambda (exp) (pcase-tests-grep fname exp)) (cdr exp)))))
+
+(ert-deftest pcase-tests-tests ()
+ (should (pcase-tests-grep 'memq '(or (+ 2 3) (memq x y))))
+ (should-not (pcase-tests-grep 'memq '(or (+ 2 3) (- x y)))))
+
+(ert-deftest pcase-tests-member ()
+ (should (pcase-tests-grep
+ 'memq (macroexpand-all '(pcase x ((or 1 2 3) body)))))
+ (should (pcase-tests-grep
+ 'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body)))))
+ (should-not (pcase-tests-grep
+ 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body)))))
+ (let ((exp (macroexpand-all
+ '(pcase x
+ ("a" body1)
+ (2 body2)
+ ((or "a" 2 3) body)))))
+ (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
+;; End:
+
+;;; pcase-tests.el ends here.
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] trunk r117919: Add pcase-defmacro, as well as `quote' and `app' patterns.,
Stefan Monnier <=