1 ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
3 ;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; ML-style pattern matching.
26 ;; The entry points are autoloaded.
30 ;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't
31 ;; use x, because x is bound separately for the equality constraint
32 ;; (as well as any pred/guard) and for the body, so uses at one place don't
33 ;; count for the other.
34 ;; - provide ways to extend the set of primitives, with some kind of
35 ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP)
36 ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
37 ;; But better would be if we could define new ways to match by having the
38 ;; extension provide its own `pcase--split-<foo>' thingy.
39 ;; - along these lines, provide patterns to match CL structs.
40 ;; - provide something like (setq VAR) so a var can be set rather than
42 ;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
44 ;; - try and be more clever to reduce the size of the decision tree, and
45 ;; to reduce the number of leaves that need to be turned into function:
46 ;; - first, do the tests shared by all remaining branches (it will have
47 ;; to be performed anyway, so better do it first so it's shared).
48 ;; - then choose the test that discriminates more (?).
49 ;; - provide Agda's `with' (along with its `...' companion).
50 ;; - implement (not UPAT). This might require a significant redesign.
51 ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
52 ;; generate a lex-style DFA to decide whether to run E1 or E2.
58 ;; Macro-expansion of pcase is reasonably fast, so it's not a problem
59 ;; when byte-compiling a file, but when interpreting the code, if the pcase
60 ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
61 ;; memoize previous macro expansions to try and avoid recomputing them
62 ;; over and over again.
63 ;; FIXME: Now that macroexpansion is also performed when loading an interpreted
64 ;; file, this is not a real problem any more.
65 (defconst pcase--memoize
(make-hash-table :weakness
'key
:test
'eq
))
66 ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
67 ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
69 (defconst pcase--dontcare-upats
'(t _ pcase--dontcare
))
71 (defvar pcase--dontwarn-upats
'(pcase--dontcare))
76 ("or" &rest pcase-UPAT
)
77 ("and" &rest pcase-UPAT
)
80 ("let" pcase-UPAT form
)
83 ;; Punt on macros/special forms.
84 (functionp &rest form
)
91 (pcase-QPAT . pcase-QPAT
)
95 (defmacro pcase
(exp &rest cases
)
96 "Perform ML-style pattern matching on EXP.
97 CASES is a list of elements of the form (UPATTERN CODE...).
99 UPatterns can take the following forms:
101 SELFQUOTING matches itself. This includes keywords, numbers, and strings.
102 SYMBOL matches anything and binds it to SYMBOL.
103 (or UPAT...) matches if any of the patterns matches.
104 (and UPAT...) matches if all the patterns match.
105 'VAL matches if the object is `equal' to VAL
106 `QPAT matches if the QPattern QPAT matches.
107 (pred PRED) matches if PRED applied to the object returns non-nil.
108 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
109 (let UPAT EXP) matches if EXP matches UPAT.
110 (app FUN UPAT) matches if FUN applied to the object matches UPAT.
111 If a SYMBOL is used twice in the same pattern (i.e. the pattern is
112 \"non-linear\"), then the second occurrence is turned into an `eq'uality test.
114 FUN can be either of the form (lambda ARGS BODY) or a symbol.
115 It has to obey the rule that if (FUN X) returns V then calling it again will
116 return the same V again (so that multiple (FUN X) can be consolidated).
118 QPatterns can take the following forms:
119 (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
120 [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match
121 its 0..(n-1)th elements, respectively.
122 ,UPAT matches if the UPattern UPAT matches.
123 STRING matches if the object is `equal' to STRING.
124 ATOM matches if the object is `eq' to ATOM.
126 PRED can take the form
127 FUNCTION in which case it gets called with one argument.
128 (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
129 which is the value being matched.
130 A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
131 PRED patterns can refer to variables bound earlier in the pattern.
132 E.g. you can match pairs where the cdr is larger than the car with a pattern
133 like `(,a . ,(pred (< a))) or, with more checks:
134 `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
135 (declare (indent 1) (debug (form &rest
(pcase-UPAT body
))))
136 ;; We want to use a weak hash table as a cache, but the key will unavoidably
137 ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
138 ;; we're called so it'll be immediately GC'd. So we use (car cases) as key
139 ;; which does come straight from the source code and should hence not be GC'd
141 (let ((data (gethash (car cases
) pcase--memoize
)))
142 ;; data = (EXP CASES . EXPANSION)
143 (if (and (equal exp
(car data
)) (equal cases
(cadr data
)))
144 ;; We have the right expansion.
146 ;; (when (gethash (car cases) pcase--memoize-1)
147 ;; (message "pcase-memoize failed because of weak key!!"))
148 ;; (when (gethash (car cases) pcase--memoize-2)
149 ;; (message "pcase-memoize failed because of eq test on %S"
152 (message "pcase-memoize: equal first branch, yet different"))
153 (let ((expansion (pcase--expand exp cases
)))
154 (puthash (car cases
) `(,exp
,cases
,@expansion
) pcase--memoize
)
155 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
156 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
160 (defmacro pcase-exhaustive
(exp &rest cases
)
161 "The exhaustive version of `pcase' (which see)."
162 (declare (indent 1) (debug pcase
))
163 (let* ((x (make-symbol "x"))
164 (pcase--dontwarn-upats (cons x pcase--dontwarn-upats
)))
166 ;; FIXME: Could we add the FILE:LINE data in the error message?
167 exp
(append cases
`((,x
(error "No clause matching `%S'" ,x
)))))))
169 (defun pcase--let* (bindings body
)
171 ((null bindings
) (macroexp-progn body
))
172 ((pcase--trivial-upat-p (caar bindings
))
173 (macroexp-let* `(,(car bindings
)) (pcase--let* (cdr bindings
) body
)))
175 (let ((binding (pop bindings
)))
178 `((,(car binding
) ,(pcase--let* bindings body
))
179 ;; We can either signal an error here, or just use `pcase--dontcare'
180 ;; which generates more efficient code. In practice, if we use
181 ;; `pcase--dontcare' we will still often get an error and the few
182 ;; cases where we don't do not matter that much, so
183 ;; it's a better choice.
184 (pcase--dontcare nil
)))))))
187 (defmacro pcase-let
* (bindings &rest body
)
188 "Like `let*' but where you can use `pcase' patterns for bindings.
189 BODY should be an expression, and BINDINGS should be a list of bindings
190 of the form (UPAT EXP)."
192 (debug ((&rest
(pcase-UPAT &optional form
)) body
)))
193 (let ((cached (gethash bindings pcase--memoize
)))
194 ;; cached = (BODY . EXPANSION)
195 (if (equal (car cached
) body
)
197 (let ((expansion (pcase--let* bindings body
)))
198 (puthash bindings
(cons body expansion
) pcase--memoize
)
202 (defmacro pcase-let
(bindings &rest body
)
203 "Like `let' but where you can use `pcase' patterns for bindings.
204 BODY should be a list of expressions, and BINDINGS should be a list of bindings
205 of the form (UPAT EXP)."
206 (declare (indent 1) (debug pcase-let
*))
207 (if (null (cdr bindings
))
208 `(pcase-let* ,bindings
,@body
)
210 (dolist (binding (prog1 bindings
(setq bindings nil
)))
212 ((memq (car binding
) pcase--dontcare-upats
)
213 (push (cons (make-symbol "_") (cdr binding
)) bindings
))
214 ((pcase--trivial-upat-p (car binding
)) (push binding bindings
))
216 (let ((tmpvar (make-symbol (format "x%d" (length bindings
)))))
217 (push (cons tmpvar
(cdr binding
)) bindings
)
218 (push (list (car binding
) tmpvar
) matches
)))))
219 `(let ,(nreverse bindings
) (pcase-let* ,matches
,@body
)))))
221 (defmacro pcase-dolist
(spec &rest body
)
222 (declare (indent 1) (debug ((pcase-UPAT form
) body
)))
223 (if (pcase--trivial-upat-p (car spec
))
224 `(dolist ,spec
,@body
)
225 (let ((tmpvar (make-symbol "x")))
226 `(dolist (,tmpvar
,@(cdr spec
))
227 (pcase-let* ((,(car spec
) ,tmpvar
))
231 (defun pcase--trivial-upat-p (upat)
232 (and (symbolp upat
) (not (memq upat pcase--dontcare-upats
))))
234 (defun pcase--expand (exp cases
)
235 ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
236 ;; (emacs-pid) exp (sxhash cases))
237 (macroexp-let2 macroexp-copyable-p val exp
242 (let ((prev (assq code seen
)))
244 (let ((res (pcase-codegen code vars
)))
245 (push (list code vars res
) seen
)
247 ;; Since we use a tree-based pattern matching
248 ;; technique, the leaves (the places that contain the
249 ;; code to run once a pattern is matched) can get
250 ;; copied a very large number of times, so to avoid
251 ;; code explosion, we need to keep track of how many
252 ;; times we've used each leaf and move it
253 ;; to a separate function if that number is too high.
255 ;; We've already used this branch. So it is shared.
256 (let* ((code (car prev
)) (cdrprev (cdr prev
))
257 (prevvars (car cdrprev
)) (cddrprev (cdr cdrprev
))
258 (res (car cddrprev
)))
259 (unless (symbolp res
)
260 ;; This is the first repeat, so we have to move
261 ;; the branch to a separate function.
263 (make-symbol (format "pcase-%d" (length defs
)))))
264 (push `(,bsym
(lambda ,(mapcar #'car prevvars
) ,@code
))
266 (setcar res
'funcall
)
267 (setcdr res
(cons bsym
(mapcar #'cdr prevvars
)))
268 (setcar (cddr prev
) bsym
)
270 (setq vars
(copy-sequence vars
))
271 (let ((args (mapcar (lambda (pa)
272 (let ((v (assq (car pa
) vars
)))
273 (setq vars
(delq v vars
))
276 ;; If some of `vars' were not found in `prevvars', that's
277 ;; OK it just means those vars aren't present in all
278 ;; branches, so they can be used within the pattern
279 ;; (e.g. by a `guard/let/pred') but not in the branch.
280 ;; FIXME: But if some of `prevvars' are not in `vars' we
281 ;; should remove them from `prevvars'!
282 `(funcall ,res
,@args
)))))))
286 (mapcar (lambda (case)
287 `((match ,val .
,(pcase--macroexpand (car case
)))
289 (unless (memq case used-cases
)
290 ;; Keep track of the cases that are used.
291 (push case used-cases
))
293 (if (pcase--small-branch-p (cdr case
))
294 ;; Don't bother sharing multiple
295 ;; occurrences of this leaf since it's small.
296 #'pcase-codegen codegen
)
301 (unless (or (memq case used-cases
)
302 (memq (car case
) pcase--dontwarn-upats
))
303 (message "Redundant pcase pattern: %S" (car case
))))
304 (macroexp-let* defs main
))))
306 (defun pcase--macroexpand (pat)
307 "Expands all macro-patterns in PAT."
308 (let ((head (car-safe pat
)))
310 ((memq head
'(nil pred guard quote
)) pat
)
311 ((memq head
'(or and
)) `(,head
,@(mapcar #'pcase--macroexpand
(cdr pat
))))
312 ((eq head
'let
) `(let ,(pcase--macroexpand (cadr pat
)) ,@(cddr pat
)))
313 ((eq head
'app
) `(app ,(nth 1 pat
) ,(pcase--macroexpand (nth 2 pat
))))
315 (let* ((expander (get head
'pcase-macroexpander
))
316 (npat (if expander
(apply expander
(cdr pat
)))))
319 "Unexpandable %s pattern: %S"
320 "Unknown %s pattern: %S")
322 (pcase--macroexpand npat
)))))))
325 (defmacro pcase-defmacro
(name args
&rest body
)
326 "Define a pcase UPattern macro."
327 (declare (indent 2) (debug (def-name sexp def-body
)) (doc-string 3))
328 `(put ',name
'pcase-macroexpander
329 (lambda ,args
,@body
)))
331 (defun pcase-codegen (code vars
)
332 ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
333 ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
334 ;; codegen from later metamorphosing this let into a funcall.
335 `(let ,(mapcar (lambda (b) (list (car b
) (cdr b
))) vars
)
338 (defun pcase--small-branch-p (code)
339 (and (= 1 (length code
))
340 (or (not (consp (car code
)))
342 (dolist (e (car code
))
343 (if (consp e
) (setq small nil
)))
346 ;; Try to use `cond' rather than a sequence of `if's, so as to reduce
347 ;; the depth of the generated tree.
348 (defun pcase--if (test then else
)
350 ((eq else
:pcase--dontcare
) then
)
351 ((eq then
:pcase--dontcare
) (debug) else
) ;Can/should this ever happen?
352 (t (macroexp-if test then else
))))
354 (defun pcase--upat (qpattern)
356 ((eq (car-safe qpattern
) '\
,) (cadr qpattern
))
357 (t (list '\
` qpattern
))))
360 ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
361 ;; check, we want to turn all the similar patterns into ones of the form
362 ;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
363 ;; Earlier code hence used branches of the form (MATCHES . CODE) where
364 ;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
365 ;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
366 ;; no easy way to eliminate the `consp' check in such a representation.
367 ;; So we replaced the MATCHES by the MATCH below which can be made up
368 ;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
369 ;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
370 ;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
371 ;; The downside is that we now have `or' and `and' both in MATCH and
372 ;; in PAT, so there are different equivalent representations and we
373 ;; need to handle them all. We do not try to systematically
374 ;; canonicalize them to one form over another, but we do occasionally
375 ;; turn one into the other.
377 (defun pcase--u (branches)
378 "Expand matcher for rules BRANCHES.
379 Each BRANCH has the form (MATCH CODE . VARS) where
380 CODE is the code generator for that branch.
381 VARS is the set of vars already bound by earlier matches.
382 MATCH is the pattern that needs to be matched, of the form:
386 (when (setq branches
(delq nil branches
))
387 (let* ((carbranch (car branches
))
388 (match (car carbranch
)) (cdarbranch (cdr carbranch
))
389 (code (car cdarbranch
))
390 (vars (cdr cdarbranch
)))
391 (pcase--u1 (list match
) code vars
(cdr branches
)))))
393 (defun pcase--and (match matches
)
394 (if matches
`(and ,match
,@matches
) match
))
396 (defconst pcase-mutually-exclusive-predicates
397 '((symbolp . integerp
)
403 (symbolp . byte-code-function-p
)
408 (integerp . byte-code-function-p
)
413 (numberp . byte-code-function-p
)
417 (consp . byte-code-function-p
)
418 (arrayp . byte-code-function-p
)
419 (vectorp . byte-code-function-p
)
421 (stringp . byte-code-function-p
)))
423 (defun pcase--mutually-exclusive-p (pred1 pred2
)
424 (or (member (cons pred1 pred2
)
425 pcase-mutually-exclusive-predicates
)
426 (member (cons pred2 pred1
)
427 pcase-mutually-exclusive-predicates
)))
429 (defun pcase--split-match (sym splitter match
)
431 ((eq (car match
) 'match
)
432 (if (not (eq sym
(cadr match
)))
434 (let ((pat (cddr match
)))
436 ;; Hoist `or' and `and' patterns to `or' and `and' matches.
437 ((memq (car-safe pat
) '(or and
))
438 (pcase--split-match sym splitter
440 (mapcar (lambda (alt)
441 `(match ,sym .
,alt
))
443 (t (let ((res (funcall splitter
(cddr match
))))
444 (cons (or (car res
) match
) (or (cdr res
) match
))))))))
445 ((memq (car match
) '(or and
))
446 (let ((then-alts '())
448 (neutral-elem (if (eq 'or
(car match
))
449 :pcase--fail
:pcase--succeed
))
450 (zero-elem (if (eq 'or
(car match
)) :pcase--succeed
:pcase--fail
)))
451 (dolist (alt (cdr match
))
452 (let ((split (pcase--split-match sym splitter alt
)))
453 (unless (eq (car split
) neutral-elem
)
454 (push (car split
) then-alts
))
455 (unless (eq (cdr split
) neutral-elem
)
456 (push (cdr split
) else-alts
))))
457 (cons (cond ((memq zero-elem then-alts
) zero-elem
)
458 ((null then-alts
) neutral-elem
)
459 ((null (cdr then-alts
)) (car then-alts
))
460 (t (cons (car match
) (nreverse then-alts
))))
461 (cond ((memq zero-elem else-alts
) zero-elem
)
462 ((null else-alts
) neutral-elem
)
463 ((null (cdr else-alts
)) (car else-alts
))
464 (t (cons (car match
) (nreverse else-alts
)))))))
465 (t (error "Uknown MATCH %s" match
))))
467 (defun pcase--split-rest (sym splitter rest
)
468 (let ((then-rest '())
470 (dolist (branch rest
)
471 (let* ((match (car branch
))
472 (code&vars
(cdr branch
))
474 (pcase--split-match sym splitter match
)))
475 (unless (eq (car split
) :pcase--fail
)
476 (push (cons (car split
) code
&vars
) then-rest
))
477 (unless (eq (cdr split
) :pcase--fail
)
478 (push (cons (cdr split
) code
&vars
) else-rest
))))
479 (cons (nreverse then-rest
) (nreverse else-rest
))))
481 (defun pcase--split-consp (syma symd pat
)
483 ;; A QPattern for a cons, can only go the `then' side.
484 ((and (eq (car-safe pat
) '\
`) (consp (cadr pat
)))
485 (let ((qpat (cadr pat
)))
486 (cons `(and (match ,syma .
,(pcase--upat (car qpat
)))
487 (match ,symd .
,(pcase--upat (cdr qpat
))))
489 ;; A QPattern but not for a cons, can only go to the `else' side.
490 ((eq (car-safe pat
) '\
`) '(:pcase--fail . nil
))
491 ((and (eq (car-safe pat
) 'pred
)
492 (pcase--mutually-exclusive-p #'consp
(cadr pat
)))
493 '(:pcase--fail . nil
))))
495 (defun pcase--split-vector (syms pat
)
497 ;; A QPattern for a vector of same length.
498 ((and (eq (car-safe pat
) '\
`)
500 (= (length syms
) (length (cadr pat
))))
501 (let ((qpat (cadr pat
)))
502 (cons `(and ,@(mapcar (lambda (s)
504 ,(pcase--upat (aref qpat
(cdr s
)))))
507 ;; Other QPatterns go to the `else' side.
508 ((eq (car-safe pat
) '\
`) '(:pcase--fail . nil
))
509 ((and (eq (car-safe pat
) 'pred
)
510 (pcase--mutually-exclusive-p #'vectorp
(cadr pat
)))
511 '(:pcase--fail . nil
))))
513 (defun pcase--split-equal (elem pat
)
515 ;; The same match will give the same result.
516 ((and (eq (car-safe pat
) '\
`) (equal (cadr pat
) elem
))
517 '(:pcase--succeed .
:pcase--fail
))
518 ;; A different match will fail if this one succeeds.
519 ((and (eq (car-safe pat
) '\
`)
520 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
521 ;; (consp (cadr pat)))
523 '(:pcase--fail . nil
))
524 ((and (eq (car-safe pat
) 'pred
)
526 (get (cadr pat
) 'side-effect-free
))
528 (if (funcall (cadr pat
) elem
)
529 '(:pcase--succeed . nil
)
530 '(:pcase--fail . nil
))))))
532 (defun pcase--split-member (elems pat
)
533 ;; Based on pcase--split-equal.
535 ;; The same match (or a match of membership in a superset) will
536 ;; give the same result, but we don't know how to check it.
538 ;; '(:pcase--succeed . nil))
539 ;; A match for one of the elements may succeed or fail.
540 ((and (eq (car-safe pat
) '\
`) (member (cadr pat
) elems
))
542 ;; A different match will fail if this one succeeds.
543 ((and (eq (car-safe pat
) '\
`)
544 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
545 ;; (consp (cadr pat)))
547 '(:pcase--fail . nil
))
548 ((and (eq (car-safe pat
) 'pred
)
550 (get (cadr pat
) 'side-effect-free
)
552 (let ((p (cadr pat
)) (all t
))
554 (unless (funcall p elem
) (setq all nil
)))
556 '(:pcase--succeed . nil
))))
558 (defun pcase--split-pred (vars upat pat
)
561 ((and (equal upat pat
)
562 ;; For predicates like (pred (> a)), two such predicates may
563 ;; actually refer to different variables `a'.
564 (or (and (eq 'pred
(car upat
)) (symbolp (cadr upat
)))
565 ;; FIXME: `vars' gives us the environment in which `upat' will
566 ;; run, but we don't have the environment in which `pat' will
567 ;; run, so we can't do a reliable verification. But let's try
568 ;; and catch at least the easy cases such as (bug#14773).
569 (not (pcase--fgrep (mapcar #'car vars
) (cadr upat
)))))
570 '(:pcase--succeed .
:pcase--fail
))
571 ((and (eq 'pred
(car upat
))
573 (cond ((eq 'pred
(car-safe pat
)) (cadr pat
))
574 ((not (eq '\
` (car-safe pat
))) nil
)
575 ((consp (cadr pat
)) #'consp
)
576 ((vectorp (cadr pat
)) #'vectorp
)
577 ((byte-code-function-p (cadr pat
))
578 #'byte-code-function-p
))))
579 (pcase--mutually-exclusive-p (cadr upat
) otherpred
)))
580 '(:pcase--fail . nil
))
581 ((and (eq 'pred
(car upat
))
582 (eq '\
` (car-safe pat
))
583 (symbolp (cadr upat
))
584 (or (symbolp (cadr pat
)) (stringp (cadr pat
)) (numberp (cadr pat
)))
585 (get (cadr upat
) 'side-effect-free
)
587 (setq test
(list (funcall (cadr upat
) (cadr pat
))))))
589 '(nil .
:pcase--fail
)
590 '(:pcase--fail . nil
))))))
592 (defun pcase--fgrep (vars sexp
)
593 "Check which of the symbols VARS appear in SEXP."
596 (dolist (var (pcase--fgrep vars
(pop sexp
)))
597 (unless (memq var res
) (push var res
))))
598 (and (memq sexp vars
) (not (memq sexp res
)) (push sexp res
))
601 (defun pcase--self-quoting-p (upat)
602 (or (keywordp upat
) (numberp upat
) (stringp upat
)))
604 (defun pcase--app-subst-match (match sym fun nsym
)
606 ((eq (car match
) 'match
)
607 (if (and (eq sym
(cadr match
))
608 (eq 'app
(car-safe (cddr match
)))
609 (equal fun
(nth 1 (cddr match
))))
610 `(match ,nsym
,@(nth 2 (cddr match
)))
612 ((memq (car match
) '(or and
))
614 ,@(mapcar (lambda (match)
615 (pcase--app-subst-match match sym fun nsym
))
617 (t (error "Uknown MATCH %s" match
))))
619 (defun pcase--app-subst-rest (rest sym fun nsym
)
620 (mapcar (lambda (branch)
621 `(,(pcase--app-subst-match (car branch
) sym fun nsym
)
625 (defsubst pcase--mark-used
(sym)
626 ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
627 (if (symbolp sym
) (put sym
'pcase-used t
)))
629 ;; It's very tempting to use `pcase' below, tho obviously, it'd create
630 ;; bootstrapping problems.
631 (defun pcase--u1 (matches code vars rest
)
632 "Return code that runs CODE (with VARS) if MATCHES match.
633 Otherwise, it defers to REST which is a list of branches of the form
634 \(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
635 ;; Depending on the order in which we choose to check each of the MATCHES,
636 ;; the resulting tree may be smaller or bigger. So in general, we'd want
637 ;; to be careful to chose the "optimal" order. But predicate
638 ;; patterns make this harder because they create dependencies
639 ;; between matches. So we don't bother trying to reorder anything.
641 ((null matches
) (funcall code vars
))
642 ((eq :pcase--fail
(car matches
)) (pcase--u rest
))
643 ((eq :pcase--succeed
(car matches
))
644 (pcase--u1 (cdr matches
) code vars rest
))
645 ((eq 'and
(caar matches
))
646 (pcase--u1 (append (cdar matches
) (cdr matches
)) code vars rest
))
647 ((eq 'or
(caar matches
))
648 (let* ((alts (cdar matches
))
649 (var (if (eq (caar alts
) 'match
) (cadr (car alts
))))
650 (simples '()) (others '()))
653 (if (and (eq (car alt
) 'match
) (eq var
(cadr alt
))
654 (let ((upat (cddr alt
)))
655 (and (eq (car-safe upat
) '\
`)
656 (or (integerp (cadr upat
)) (symbolp (cadr upat
))
657 (stringp (cadr upat
))))))
658 (push (cddr alt
) simples
)
661 ((null alts
) (error "Please avoid it") (pcase--u rest
))
662 ((> (length simples
) 1)
663 ;; De-hoist the `or' MATCH into an `or' pattern that will be
664 ;; turned into a `memq' below.
665 (pcase--u1 (cons `(match ,var or .
,(nreverse simples
)) (cdr matches
))
667 (if (null others
) rest
669 (pcase--and (if (cdr others
)
670 (cons 'or
(nreverse others
))
676 (pcase--u1 (cons (pop alts
) (cdr matches
)) code vars
677 (if (null alts
) (progn (error "Please avoid it") rest
)
679 (pcase--and (if (cdr alts
)
680 (cons 'or alts
) (car alts
))
684 ((eq 'match
(caar matches
))
685 (let* ((popmatches (pop matches
))
686 (_op (car popmatches
)) (cdrpopmatches (cdr popmatches
))
687 (sym (car cdrpopmatches
))
688 (upat (cdr cdrpopmatches
)))
690 ((memq upat
'(t _
)) (pcase--u1 matches code vars rest
))
691 ((eq upat
'pcase--dontcare
) :pcase--dontcare
)
692 ((memq (car-safe upat
) '(guard pred
))
693 (if (eq (car upat
) 'pred
) (pcase--mark-used sym
))
696 sym
(lambda (pat) (pcase--split-pred vars upat pat
)) rest
))
697 (then-rest (car splitrest
))
698 (else-rest (cdr splitrest
)))
699 (pcase--if (if (and (eq (car upat
) 'pred
) (symbolp (cadr upat
)))
701 (let* ((exp (cadr upat
))
702 ;; `vs' is an upper bound on the vars we need.
703 (vs (pcase--fgrep (mapcar #'car vars
) exp
))
704 (env (mapcar (lambda (var)
705 (list var
(cdr (assq var vars
))))
707 (call (if (eq 'guard
(car upat
))
710 ;; `sym' is shadowed by `env'.
711 (let ((newsym (make-symbol "x")))
712 (push (list newsym sym
) env
)
715 `(funcall #',exp
,sym
)
719 ;; Let's not replace `vars' in `exp' since it's
720 ;; too difficult to do it right, instead just
721 ;; let-bind `vars' around `exp'.
722 `(let* ,env
,call
))))
723 (pcase--u1 matches code vars then-rest
)
724 (pcase--u else-rest
))))
725 ((pcase--self-quoting-p upat
)
726 (pcase--mark-used sym
)
727 (pcase--q1 sym upat matches code vars rest
))
729 (pcase--mark-used sym
)
730 (if (not (assq upat vars
))
731 (pcase--u1 matches code
(cons (cons upat sym
) vars
) rest
)
732 ;; Non-linear pattern. Turn it into an `eq' test.
733 (pcase--u1 (cons `(match ,sym .
(pred (eq ,(cdr (assq upat vars
)))))
736 ((eq (car-safe upat
) 'let
)
737 ;; A upat of the form (let VAR EXP).
738 ;; (pcase--u1 matches code
739 ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
741 macroexp-copyable-p sym
742 (let* ((exp (nth 2 upat
))
743 (found (assq exp vars
)))
744 (if found
(cdr found
)
745 (let* ((vs (pcase--fgrep (mapcar #'car vars
) exp
))
746 (env (mapcar (lambda (v) (list v
(cdr (assq v vars
))))
748 (if env
(macroexp-let* env exp
) exp
))))
749 (pcase--u1 (cons `(match ,sym .
,(nth 1 upat
)) matches
)
751 ((eq (car-safe upat
) 'app
)
752 ;; A upat of the form (app FUN UPAT)
753 (pcase--mark-used sym
)
754 (let* ((fun (nth 1 upat
)))
756 macroexp-copyable-p nsym
759 (let* ((vs (pcase--fgrep (mapcar #'car vars
) fun
))
760 (env (mapcar (lambda (v) (list v
(cdr (assq v vars
))))
762 (call `(funcall #',fun
,sym
)))
763 (if env
(macroexp-let* env call
) call
)))
764 ;; We don't change `matches' to reuse the newly computed value,
765 ;; because we assume there shouldn't be such redundancy in there.
766 (pcase--u1 (cons `(match ,nsym
,@(nth 2 upat
)) matches
)
768 (pcase--app-subst-rest rest sym fun nsym
)))))
769 ((eq (car-safe upat
) '\
`)
770 (pcase--mark-used sym
)
771 (pcase--q1 sym
(cadr upat
) matches code vars rest
))
772 ((eq (car-safe upat
) 'quote
)
773 (let* ((val (cadr upat
))
774 (splitrest (pcase--split-rest
775 sym
(lambda (pat) (pcase--split-equal val pat
)) rest
))
776 (then-rest (car splitrest
))
777 (else-rest (cdr splitrest
)))
779 ((null val
) `(null ,sym
))
780 ((or (integerp val
) (symbolp val
))
782 (t `(equal ,sym
',val
)))
783 (pcase--u1 matches code vars then-rest
)
784 (pcase--u else-rest
))))
785 ((eq (car-safe upat
) 'or
)
786 (let ((all (> (length (cdr upat
)) 1))
789 (dolist (alt (cdr upat
))
790 (unless (if (pcase--self-quoting-p alt
)
792 (unless (or (symbolp alt
) (integerp alt
))
793 (setq memq-fine nil
))
795 (and (eq (car-safe alt
) '\
`)
796 (or (symbolp (cadr alt
)) (integerp (cadr alt
))
798 (stringp (cadr alt
)))))
801 ;; Use memq for (or `a `b `c `d) rather than a big tree.
802 (let* ((elems (mapcar (lambda (x) (if (consp x
) (cadr x
) x
))
806 sym
(lambda (pat) (pcase--split-member elems pat
)) rest
))
807 (then-rest (car splitrest
))
808 (else-rest (cdr splitrest
)))
809 (pcase--mark-used sym
)
810 (pcase--if `(,(if memq-fine
#'memq
#'member
) ,sym
',elems
)
811 (pcase--u1 matches code vars then-rest
)
812 (pcase--u else-rest
)))
813 (pcase--u1 (cons `(match ,sym
,@(cadr upat
)) matches
) code vars
814 (append (mapcar (lambda (upat)
815 `((and (match ,sym .
,upat
) ,@matches
)
819 ((eq (car-safe upat
) 'and
)
820 (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym
,@upat
))
824 ((eq (car-safe upat
) 'not
)
825 ;; FIXME: The implementation below is naive and results in
827 ;; To make it work right, we would need to turn pcase--u1's
828 ;; `code' and `vars' into a single argument of the same form as
829 ;; `rest'. We would also need to split this new `then-rest' argument
830 ;; for every test (currently we don't bother to do it since
831 ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
832 ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
833 ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
834 (pcase--u1 `((match ,sym .
,(cadr upat
)))
835 ;; FIXME: This codegen is not careful to share its
836 ;; code if used several times: code blow up is likely.
838 ;; `vars' will likely contain bindings which are
839 ;; not always available in other paths to
840 ;; `rest', so there' no point trying to pass
844 (list `((and .
,matches
) ,code .
,vars
))))
845 (t (error "Unknown upattern `%s'" upat
)))))
846 (t (error "Incorrect MATCH %s" (car matches
)))))
848 (defun pcase--q1 (sym qpat matches code vars rest
)
849 "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
850 Otherwise, it defers to REST which is a list of branches of the form
851 \(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
853 ((eq (car-safe qpat
) '\
,) (error "Can't use `,UPATTERN"))
854 ((floatp qpat
) (error "Floating point patterns not supported"))
856 (let* ((len (length qpat
))
857 (syms (mapcar (lambda (i) (cons (make-symbol (format "xaref%s" i
)) i
))
858 (number-sequence 0 (1- len
))))
859 (splitrest (pcase--split-rest
861 (lambda (pat) (pcase--split-vector syms pat
))
863 (then-rest (car splitrest
))
864 (else-rest (cdr splitrest
))
865 (then-body (pcase--u1
866 `(,@(mapcar (lambda (s)
868 ,(pcase--upat (aref qpat
(cdr s
)))))
871 code vars then-rest
)))
873 `(and (vectorp ,sym
) (= (length ,sym
) ,len
))
874 (macroexp-let* (delq nil
(mapcar (lambda (s)
875 (and (get (car s
) 'pcase-used
)
876 `(,(car s
) (aref ,sym
,(cdr s
)))))
879 (pcase--u else-rest
))))
881 (let* ((syma (make-symbol "xcar"))
882 (symd (make-symbol "xcdr"))
883 (splitrest (pcase--split-rest
885 (lambda (pat) (pcase--split-consp syma symd pat
))
887 (then-rest (car splitrest
))
888 (else-rest (cdr splitrest
))
889 (then-body (pcase--u1 `((match ,syma .
,(pcase--upat (car qpat
)))
890 (match ,symd .
,(pcase--upat (cdr qpat
)))
892 code vars then-rest
)))
895 ;; We want to be careful to only add bindings that are used.
896 ;; The byte-compiler could do that for us, but it would have to pay
897 ;; attention to the `consp' test in order to figure out that car/cdr
898 ;; can't signal errors and our byte-compiler is not that clever.
899 ;; FIXME: Some of those let bindings occur too early (they are used in
900 ;; `then-body', but only within some sub-branch).
902 `(,@(if (get syma
'pcase-used
) `((,syma
(car ,sym
))))
903 ,@(if (get symd
'pcase-used
) `((,symd
(cdr ,sym
)))))
905 (pcase--u else-rest
))))
906 ((or (integerp qpat
) (symbolp qpat
) (stringp qpat
))
907 (let* ((splitrest (pcase--split-rest
908 sym
(lambda (pat) (pcase--split-equal qpat pat
)) rest
))
909 (then-rest (car splitrest
))
910 (else-rest (cdr splitrest
)))
912 ((stringp qpat
) `(equal ,sym
,qpat
))
913 ((null qpat
) `(null ,sym
))
914 (t `(eq ,sym
',qpat
)))
915 (pcase--u1 matches code vars then-rest
)
916 (pcase--u else-rest
))))
917 (t (error "Unknown QPattern %s" qpat
))))
921 ;;; pcase.el ends here