Optimise assoc and rassoc with symbol key to assq and rassq
[emacs.git] / lisp / emacs-lisp / pcase.el
bloba8ce23284c4f0eec8e1c62067a92b6ae312e46d4
1 ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
3 ;; Copyright (C) 2010-2020 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6 ;; Keywords:
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 <https://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;; ML-style pattern matching.
26 ;; The entry points are autoloaded.
28 ;; Todo:
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
41 ;; let-bound.
42 ;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
43 ;; this :-()
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 PAT). 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.
54 ;;; Code:
56 (require 'macroexp)
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 (make-hash-table :test 'eq))
67 ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
68 ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
70 (defconst pcase--dontcare-upats '(t _ pcase--dontcare))
72 (defvar pcase--dontwarn-upats '(pcase--dontcare))
74 (def-edebug-spec
75 pcase-PAT
76 (&or symbolp
77 ("or" &rest pcase-PAT)
78 ("and" &rest pcase-PAT)
79 ("guard" form)
80 ("let" pcase-PAT form)
81 ("pred" pcase-FUN)
82 ("app" pcase-FUN pcase-PAT)
83 pcase-MACRO
84 sexp))
86 (def-edebug-spec
87 pcase-FUN
88 (&or lambda-expr
89 ;; Punt on macros/special forms.
90 (functionp &rest form)
91 sexp))
93 ;; See bug#24717
94 (put 'pcase-MACRO 'edebug-form-spec 'pcase--edebug-match-macro)
96 ;; Only called from edebug.
97 (declare-function get-edebug-spec "edebug" (symbol))
98 (declare-function edebug-match "edebug" (cursor specs))
100 (defun pcase--edebug-match-macro (cursor)
101 (let (specs)
102 (mapatoms
103 (lambda (s)
104 (let ((m (get s 'pcase-macroexpander)))
105 (when (and m (get-edebug-spec m))
106 (push (cons (symbol-name s) (get-edebug-spec m))
107 specs)))))
108 (edebug-match cursor (cons '&or specs))))
110 ;;;###autoload
111 (defmacro pcase (exp &rest cases)
112 "Evaluate EXP to get EXPVAL; try passing control to one of CASES.
113 CASES is a list of elements of the form (PATTERN CODE...).
114 For the first CASE whose PATTERN \"matches\" EXPVAL,
115 evaluate its CODE..., and return the value of the last form.
116 If no CASE has a PATTERN that matches, return nil.
118 Each PATTERN expands, in essence, to a predicate to call
119 on EXPVAL. When the return value of that call is non-nil,
120 PATTERN matches. PATTERN can take one of the forms:
122 _ matches anything.
123 \\='VAL matches if EXPVAL is `equal' to VAL.
124 KEYWORD shorthand for \\='KEYWORD
125 INTEGER shorthand for \\='INTEGER
126 STRING shorthand for \\='STRING
127 SYMBOL matches anything and binds it to SYMBOL.
128 If a SYMBOL is used twice in the same pattern
129 the second occurrence becomes an `eq'uality test.
130 (pred FUN) matches if FUN called on EXPVAL returns non-nil.
131 (app FUN PAT) matches if FUN called on EXPVAL matches PAT.
132 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
133 (let PAT EXPR) matches if EXPR matches PAT.
134 (and PAT...) matches if all the patterns match.
135 (or PAT...) matches if any of the patterns matches.
137 FUN in `pred' and `app' can take one of the forms:
138 SYMBOL or (lambda ARGS BODY)
139 call it with one argument
140 (F ARG1 .. ARGn)
141 call F with ARG1..ARGn and EXPVAL as n+1'th argument
143 FUN, BOOLEXP, EXPR, and subsequent PAT can refer to variables
144 bound earlier in the pattern by a SYMBOL pattern.
146 Additional patterns can be defined using `pcase-defmacro'.
148 See Info node `(elisp) Pattern-Matching Conditional' in the
149 Emacs Lisp manual for more information and examples."
150 (declare (indent 1) (debug (form &rest (pcase-PAT body))))
151 ;; We want to use a weak hash table as a cache, but the key will unavoidably
152 ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
153 ;; we're called so it'll be immediately GC'd. So we use (car cases) as key
154 ;; which does come straight from the source code and should hence not be GC'd
155 ;; so easily.
156 (let ((data (gethash (car cases) pcase--memoize)))
157 ;; data = (EXP CASES . EXPANSION)
158 (if (and (equal exp (car data)) (equal cases (cadr data)))
159 ;; We have the right expansion.
160 (cddr data)
161 ;; (when (gethash (car cases) pcase--memoize-1)
162 ;; (message "pcase-memoize failed because of weak key!!"))
163 ;; (when (gethash (car cases) pcase--memoize-2)
164 ;; (message "pcase-memoize failed because of eq test on %S"
165 ;; (car cases)))
166 ;; (when data
167 ;; (message "pcase-memoize: equal first branch, yet different"))
168 (let ((expansion (pcase--expand exp cases)))
169 (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
170 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
171 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
172 expansion))))
174 (declare-function help-fns--signature "help-fns"
175 (function doc real-def real-function buffer))
177 ;; FIXME: Obviously, this will collide with nadvice's use of
178 ;; function-documentation if we happen to advise `pcase'.
179 ;;;###autoload
180 (put 'pcase 'function-documentation '(pcase--make-docstring))
181 ;;;###autoload
182 (defun pcase--make-docstring ()
183 (let* ((main (documentation (symbol-function 'pcase) 'raw))
184 (ud (help-split-fundoc main 'pcase)))
185 ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works,
186 ;; where cl-lib is anything using pcase-defmacro.
187 (require 'help-fns)
188 (with-temp-buffer
189 (insert (or (cdr ud) main))
190 ;; Presentation Note: For conceptual continuity, we guarantee
191 ;; that backquote doc immediately follows main pcase doc.
192 ;; (The order of the other extensions is unimportant.)
193 (let (more)
194 ;; Collect all the extensions.
195 (mapatoms (lambda (symbol)
196 (let ((me (get symbol 'pcase-macroexpander)))
197 (when me
198 (push (cons symbol me)
199 more)))))
200 ;; Ensure backquote is first.
201 (let ((x (assq '\` more)))
202 (setq more (cons x (delq x more))))
203 ;; Do the output.
204 (while more
205 (let* ((pair (pop more))
206 (symbol (car pair))
207 (me (cdr pair))
208 (doc (documentation me 'raw)))
209 (insert "\n\n-- ")
210 (setq doc (help-fns--signature symbol doc me
211 (indirect-function me)
212 nil))
213 (insert "\n" (or doc "Not documented.")))))
214 (let ((combined-doc (buffer-string)))
215 (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
217 ;;;###autoload
218 (defmacro pcase-exhaustive (exp &rest cases)
219 "The exhaustive version of `pcase' (which see).
220 If EXP fails to match any of the patterns in CASES, an error is signaled."
221 (declare (indent 1) (debug pcase))
222 (let* ((x (gensym "x"))
223 (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
224 (pcase--expand
225 ;; FIXME: Could we add the FILE:LINE data in the error message?
226 exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
228 ;;;###autoload
229 (defmacro pcase-lambda (lambda-list &rest body)
230 "Like `lambda' but allow each argument to be a pattern.
231 I.e. accepts the usual &optional and &rest keywords, but every
232 formal argument can be any pattern accepted by `pcase' (a mere
233 variable name being but a special case of it)."
234 (declare (doc-string 2) (indent defun)
235 (debug (&define (&rest pcase-PAT) lambda-doc def-body)))
236 (let* ((bindings ())
237 (parsed-body (macroexp-parse-body body))
238 (args (mapcar (lambda (pat)
239 (if (symbolp pat)
240 ;; Simple vars and &rest/&optional are just passed
241 ;; through unchanged.
243 (let ((arg (make-symbol
244 (format "arg%s" (length bindings)))))
245 (push `(,pat ,arg) bindings)
246 arg)))
247 lambda-list)))
248 `(lambda ,args ,@(car parsed-body)
249 (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body)))))
251 (defun pcase--let* (bindings body)
252 (cond
253 ((null bindings) (macroexp-progn body))
254 ((pcase--trivial-upat-p (caar bindings))
255 (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
257 (let ((binding (pop bindings)))
258 (pcase--expand
259 (cadr binding)
260 `((,(car binding) ,(pcase--let* bindings body))
261 ;; We can either signal an error here, or just use `pcase--dontcare'
262 ;; which generates more efficient code. In practice, if we use
263 ;; `pcase--dontcare' we will still often get an error and the few
264 ;; cases where we don't do not matter that much, so
265 ;; it's a better choice.
266 (pcase--dontcare nil)))))))
268 ;;;###autoload
269 (defmacro pcase-let* (bindings &rest body)
270 "Like `let*', but supports destructuring BINDINGS using `pcase' patterns.
271 As with `pcase-let', BINDINGS are of the form (PATTERN EXP), but the
272 EXP in each binding in BINDINGS can use the results of the destructuring
273 bindings that precede it in BINDINGS' order.
275 Each EXP should match (i.e. be of compatible structure) to its
276 respective PATTERN; a mismatch may signal an error or may go
277 undetected, binding variables to arbitrary values, such as nil."
278 (declare (indent 1)
279 (debug ((&rest (pcase-PAT &optional form)) body)))
280 (let ((cached (gethash bindings pcase--memoize)))
281 ;; cached = (BODY . EXPANSION)
282 (if (equal (car cached) body)
283 (cdr cached)
284 (let ((expansion (pcase--let* bindings body)))
285 (puthash bindings (cons body expansion) pcase--memoize)
286 expansion))))
288 ;;;###autoload
289 (defmacro pcase-let (bindings &rest body)
290 "Like `let', but supports destructuring BINDINGS using `pcase' patterns.
291 BODY should be a list of expressions, and BINDINGS should be a list of
292 bindings of the form (PATTERN EXP).
293 All EXPs are evaluated first, and then used to perform destructuring
294 bindings by matching each EXP against its respective PATTERN. Then
295 BODY is evaluated with those bindings in effect.
297 Each EXP should match (i.e. be of compatible structure) to its
298 respective PATTERN; a mismatch may signal an error or may go
299 undetected, binding variables to arbitrary values, such as nil."
300 (declare (indent 1) (debug pcase-let*))
301 (if (null (cdr bindings))
302 `(pcase-let* ,bindings ,@body)
303 (let ((matches '()))
304 (dolist (binding (prog1 bindings (setq bindings nil)))
305 (cond
306 ((memq (car binding) pcase--dontcare-upats)
307 (push (cons (make-symbol "_") (cdr binding)) bindings))
308 ((pcase--trivial-upat-p (car binding)) (push binding bindings))
310 (let ((tmpvar (make-symbol (format "x%d" (length bindings)))))
311 (push (cons tmpvar (cdr binding)) bindings)
312 (push (list (car binding) tmpvar) matches)))))
313 `(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
315 ;;;###autoload
316 (defmacro pcase-dolist (spec &rest body)
317 "Eval BODY once for each set of bindings defined by PATTERN and LIST elements.
318 PATTERN should be a `pcase' pattern describing the structure of
319 LIST elements, and LIST is a list of objects that match PATTERN,
320 i.e. have a structure that is compatible with PATTERN.
321 For each element of LIST, this macro binds the variables in
322 PATTERN to the corresponding subfields of the LIST element, and
323 then evaluates BODY with these bindings in effect. The
324 destructuring bindings of variables in PATTERN to the subfields
325 of the elements of LIST is performed as if by `pcase-let'.
326 \n(fn (PATTERN LIST) BODY...)"
327 (declare (indent 1) (debug ((pcase-PAT form) body)))
328 (if (pcase--trivial-upat-p (car spec))
329 `(dolist ,spec ,@body)
330 (let ((tmpvar (gensym "x")))
331 `(dolist (,tmpvar ,@(cdr spec))
332 (pcase-let* ((,(car spec) ,tmpvar))
333 ,@body)))))
336 (defun pcase--trivial-upat-p (upat)
337 (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
339 (defun pcase--expand (exp cases)
340 ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
341 ;; (emacs-pid) exp (sxhash cases))
342 (macroexp-let2 macroexp-copyable-p val exp
343 (let* ((defs ())
344 (seen '())
345 (codegen
346 (lambda (code vars)
347 (let ((vars (pcase--fgrep vars code))
348 (prev (assq code seen)))
349 (if (not prev)
350 (let ((res (pcase-codegen code vars)))
351 (push (list code vars res) seen)
352 res)
353 ;; Since we use a tree-based pattern matching
354 ;; technique, the leaves (the places that contain the
355 ;; code to run once a pattern is matched) can get
356 ;; copied a very large number of times, so to avoid
357 ;; code explosion, we need to keep track of how many
358 ;; times we've used each leaf and move it
359 ;; to a separate function if that number is too high.
361 ;; We've already used this branch. So it is shared.
362 (let* ((code (car prev)) (cdrprev (cdr prev))
363 (prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
364 (res (car cddrprev)))
365 (unless (symbolp res)
366 ;; This is the first repeat, so we have to move
367 ;; the branch to a separate function.
368 (let ((bsym
369 (make-symbol (format "pcase-%d" (length defs)))))
370 (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code))
371 defs)
372 (setcar res 'funcall)
373 (setcdr res (cons bsym (mapcar #'cdr prevvars)))
374 (setcar (cddr prev) bsym)
375 (setq res bsym)))
376 (setq vars (copy-sequence vars))
377 (let ((args (mapcar (lambda (pa)
378 (let ((v (assq (car pa) vars)))
379 (setq vars (delq v vars))
380 (cdr v)))
381 prevvars)))
382 ;; If some of `vars' were not found in `prevvars', that's
383 ;; OK it just means those vars aren't present in all
384 ;; branches, so they can be used within the pattern
385 ;; (e.g. by a `guard/let/pred') but not in the branch.
386 ;; FIXME: But if some of `prevvars' are not in `vars' we
387 ;; should remove them from `prevvars'!
388 `(funcall ,res ,@args)))))))
389 (used-cases ())
390 (main
391 (pcase--u
392 (mapcar (lambda (case)
393 `(,(pcase--match val (pcase--macroexpand (car case)))
394 ,(lambda (vars)
395 (unless (memq case used-cases)
396 ;; Keep track of the cases that are used.
397 (push case used-cases))
398 (funcall
399 (if (pcase--small-branch-p (cdr case))
400 ;; Don't bother sharing multiple
401 ;; occurrences of this leaf since it's small.
402 (lambda (code vars)
403 (pcase-codegen code
404 (pcase--fgrep vars code)))
405 codegen)
406 (cdr case)
407 vars))))
408 cases))))
409 (dolist (case cases)
410 (unless (or (memq case used-cases)
411 (memq (car case) pcase--dontwarn-upats))
412 (message "Redundant pcase pattern: %S" (car case))))
413 (macroexp-let* defs main))))
415 (defun pcase--macroexpand (pat)
416 "Expands all macro-patterns in PAT."
417 (let ((head (car-safe pat)))
418 (cond
419 ((null head)
420 (if (pcase--self-quoting-p pat) `',pat pat))
421 ((memq head '(pred guard quote)) pat)
422 ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
423 ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
424 ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
426 (let* ((expander (get head 'pcase-macroexpander))
427 (npat (if expander (apply expander (cdr pat)))))
428 (if (null npat)
429 (error (if expander
430 "Unexpandable %s pattern: %S"
431 "Unknown %s pattern: %S")
432 head pat)
433 (pcase--macroexpand npat)))))))
435 ;;;###autoload
436 (defmacro pcase-defmacro (name args &rest body)
437 "Define a new kind of pcase PATTERN, by macro expansion.
438 Patterns of the form (NAME ...) will be expanded according
439 to this macro.
441 By convention, DOC should use \"EXPVAL\" to stand
442 for the result of evaluating EXP (first arg to `pcase').
443 \n(fn NAME ARGS [DOC] &rest BODY...)"
444 (declare (indent 2) (debug defun) (doc-string 3))
445 ;; Add the function via `fsym', so that an autoload cookie placed
446 ;; on a pcase-defmacro will cause the macro to be loaded on demand.
447 (let ((fsym (intern (format "%s--pcase-macroexpander" name)))
448 (decl (assq 'declare body)))
449 (when decl (setq body (remove decl body)))
450 `(progn
451 (defun ,fsym ,args ,@body)
452 (define-symbol-prop ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
453 (define-symbol-prop ',name 'pcase-macroexpander #',fsym))))
455 (defun pcase--match (val upat)
456 "Build a MATCH structure, hoisting all `or's and `and's outside."
457 (cond
458 ;; Hoist or/and patterns into or/and matches.
459 ((memq (car-safe upat) '(or and))
460 `(,(car upat)
461 ,@(mapcar (lambda (upat)
462 (pcase--match val upat))
463 (cdr upat))))
465 `(match ,val . ,upat))))
467 (defun pcase-codegen (code vars)
468 ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
469 ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
470 ;; codegen from later metamorphosing this let into a funcall.
471 (if vars
472 `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
473 ,@code)
474 `(progn ,@code)))
476 (defun pcase--small-branch-p (code)
477 (and (= 1 (length code))
478 (or (not (consp (car code)))
479 (let ((small t))
480 (dolist (e (car code))
481 (if (consp e) (setq small nil)))
482 small))))
484 ;; Try to use `cond' rather than a sequence of `if's, so as to reduce
485 ;; the depth of the generated tree.
486 (defun pcase--if (test then else)
487 (cond
488 ((eq else :pcase--dontcare) then)
489 ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
490 (t (macroexp-if test then else))))
492 ;; Note about MATCH:
493 ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
494 ;; check, we want to turn all the similar patterns into ones of the form
495 ;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
496 ;; Earlier code hence used branches of the form (MATCHES . CODE) where
497 ;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
498 ;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
499 ;; no easy way to eliminate the `consp' check in such a representation.
500 ;; So we replaced the MATCHES by the MATCH below which can be made up
501 ;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
502 ;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
503 ;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
504 ;; The downside is that we now have `or' and `and' both in MATCH and
505 ;; in PAT, so there are different equivalent representations and we
506 ;; need to handle them all. We do not try to systematically
507 ;; canonicalize them to one form over another, but we do occasionally
508 ;; turn one into the other.
510 (defun pcase--u (branches)
511 "Expand matcher for rules BRANCHES.
512 Each BRANCH has the form (MATCH CODE . VARS) where
513 CODE is the code generator for that branch.
514 VARS is the set of vars already bound by earlier matches.
515 MATCH is the pattern that needs to be matched, of the form:
516 (match VAR . PAT)
517 (and MATCH ...)
518 (or MATCH ...)"
519 (when (setq branches (delq nil branches))
520 (let* ((carbranch (car branches))
521 (match (car carbranch)) (cdarbranch (cdr carbranch))
522 (code (car cdarbranch))
523 (vars (cdr cdarbranch)))
524 (pcase--u1 (list match) code vars (cdr branches)))))
526 (defun pcase--and (match matches)
527 (if matches `(and ,match ,@matches) match))
529 (defconst pcase-mutually-exclusive-predicates
530 '((symbolp . integerp)
531 (symbolp . numberp)
532 (symbolp . consp)
533 (symbolp . arrayp)
534 (symbolp . vectorp)
535 (symbolp . stringp)
536 (symbolp . byte-code-function-p)
537 (symbolp . recordp)
538 (integerp . consp)
539 (integerp . arrayp)
540 (integerp . vectorp)
541 (integerp . stringp)
542 (integerp . byte-code-function-p)
543 (integerp . recordp)
544 (numberp . consp)
545 (numberp . arrayp)
546 (numberp . vectorp)
547 (numberp . stringp)
548 (numberp . byte-code-function-p)
549 (numberp . recordp)
550 (consp . arrayp)
551 (consp . atom)
552 (consp . vectorp)
553 (consp . stringp)
554 (consp . byte-code-function-p)
555 (consp . recordp)
556 (arrayp . byte-code-function-p)
557 (vectorp . byte-code-function-p)
558 (vectorp . recordp)
559 (stringp . vectorp)
560 (stringp . recordp)
561 (stringp . byte-code-function-p)))
563 (defun pcase--mutually-exclusive-p (pred1 pred2)
564 (or (member (cons pred1 pred2)
565 pcase-mutually-exclusive-predicates)
566 (member (cons pred2 pred1)
567 pcase-mutually-exclusive-predicates)))
569 (defun pcase--split-match (sym splitter match)
570 (cond
571 ((eq (car-safe match) 'match)
572 (if (not (eq sym (cadr match)))
573 (cons match match)
574 (let ((res (funcall splitter (cddr match))))
575 (cons (or (car res) match) (or (cdr res) match)))))
576 ((memq (car-safe match) '(or and))
577 (let ((then-alts '())
578 (else-alts '())
579 (neutral-elem (if (eq 'or (car match))
580 :pcase--fail :pcase--succeed))
581 (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail)))
582 (dolist (alt (cdr match))
583 (let ((split (pcase--split-match sym splitter alt)))
584 (unless (eq (car split) neutral-elem)
585 (push (car split) then-alts))
586 (unless (eq (cdr split) neutral-elem)
587 (push (cdr split) else-alts))))
588 (cons (cond ((memq zero-elem then-alts) zero-elem)
589 ((null then-alts) neutral-elem)
590 ((null (cdr then-alts)) (car then-alts))
591 (t (cons (car match) (nreverse then-alts))))
592 (cond ((memq zero-elem else-alts) zero-elem)
593 ((null else-alts) neutral-elem)
594 ((null (cdr else-alts)) (car else-alts))
595 (t (cons (car match) (nreverse else-alts)))))))
596 ((memq match '(:pcase--succeed :pcase--fail)) (cons match match))
597 (t (error "Uknown MATCH %s" match))))
599 (defun pcase--split-rest (sym splitter rest)
600 (let ((then-rest '())
601 (else-rest '()))
602 (dolist (branch rest)
603 (let* ((match (car branch))
604 (code&vars (cdr branch))
605 (split
606 (pcase--split-match sym splitter match)))
607 (unless (eq (car split) :pcase--fail)
608 (push (cons (car split) code&vars) then-rest))
609 (unless (eq (cdr split) :pcase--fail)
610 (push (cons (cdr split) code&vars) else-rest))))
611 (cons (nreverse then-rest) (nreverse else-rest))))
613 (defun pcase--split-equal (elem pat)
614 (cond
615 ;; The same match will give the same result.
616 ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem))
617 '(:pcase--succeed . :pcase--fail))
618 ;; A different match will fail if this one succeeds.
619 ((and (eq (car-safe pat) 'quote)
620 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
621 ;; (consp (cadr pat)))
623 '(:pcase--fail . nil))
624 ((and (eq (car-safe pat) 'pred)
625 (symbolp (cadr pat))
626 (get (cadr pat) 'side-effect-free))
627 (ignore-errors
628 (if (funcall (cadr pat) elem)
629 '(:pcase--succeed . nil)
630 '(:pcase--fail . nil))))))
632 (defun pcase--split-member (elems pat)
633 ;; FIXME: The new pred-based member code doesn't do these optimizations!
634 ;; Based on pcase--split-equal.
635 (cond
636 ;; The same match (or a match of membership in a superset) will
637 ;; give the same result, but we don't know how to check it.
638 ;; (???
639 ;; '(:pcase--succeed . nil))
640 ;; A match for one of the elements may succeed or fail.
641 ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems))
642 nil)
643 ;; A different match will fail if this one succeeds.
644 ((and (eq (car-safe pat) 'quote)
645 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
646 ;; (consp (cadr pat)))
648 '(:pcase--fail . nil))
649 ((and (eq (car-safe pat) 'pred)
650 (symbolp (cadr pat))
651 (get (cadr pat) 'side-effect-free)
652 (ignore-errors
653 (let ((p (cadr pat)) (all t))
654 (dolist (elem elems)
655 (unless (funcall p elem) (setq all nil)))
656 all)))
657 '(:pcase--succeed . nil))))
659 (defun pcase--split-pred (vars upat pat)
660 (let (test)
661 (cond
662 ((and (equal upat pat)
663 ;; For predicates like (pred (> a)), two such predicates may
664 ;; actually refer to different variables `a'.
665 (or (and (eq 'pred (car upat)) (symbolp (cadr upat)))
666 ;; FIXME: `vars' gives us the environment in which `upat' will
667 ;; run, but we don't have the environment in which `pat' will
668 ;; run, so we can't do a reliable verification. But let's try
669 ;; and catch at least the easy cases such as (bug#14773).
670 (not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
671 '(:pcase--succeed . :pcase--fail))
672 ((and (eq 'pred (car upat))
673 (let ((otherpred
674 (cond ((eq 'pred (car-safe pat)) (cadr pat))
675 ((not (eq 'quote (car-safe pat))) nil)
676 ((consp (cadr pat)) #'consp)
677 ((stringp (cadr pat)) #'stringp)
678 ((vectorp (cadr pat)) #'vectorp)
679 ((byte-code-function-p (cadr pat))
680 #'byte-code-function-p))))
681 (pcase--mutually-exclusive-p (cadr upat) otherpred)))
682 '(:pcase--fail . nil))
683 ((and (eq 'pred (car upat))
684 (eq 'quote (car-safe pat))
685 (symbolp (cadr upat))
686 (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
687 (get (cadr upat) 'side-effect-free)
688 (ignore-errors
689 (setq test (list (funcall (cadr upat) (cadr pat))))))
690 (if (car test)
691 '(nil . :pcase--fail)
692 '(:pcase--fail . nil))))))
694 (defun pcase--fgrep (bindings sexp)
695 "Return those of the BINDINGS which might be used in SEXP."
696 (let ((res '()))
697 (while (and (consp sexp) bindings)
698 (dolist (binding (pcase--fgrep bindings (pop sexp)))
699 (push binding res)
700 (setq bindings (remove binding bindings))))
701 (if (vectorp sexp)
702 ;; With backquote, code can appear within vectors as well.
703 ;; This wouldn't be needed if we `macroexpand-all' before
704 ;; calling pcase--fgrep, OTOH.
705 (pcase--fgrep bindings (mapcar #'identity sexp))
706 (let ((tmp (assq sexp bindings)))
707 (if tmp
708 (cons tmp res)
709 res)))))
711 (defun pcase--self-quoting-p (upat)
712 (or (keywordp upat) (integerp upat) (stringp upat)))
714 (defun pcase--app-subst-match (match sym fun nsym)
715 (cond
716 ((eq (car-safe match) 'match)
717 (if (and (eq sym (cadr match))
718 (eq 'app (car-safe (cddr match)))
719 (equal fun (nth 1 (cddr match))))
720 (pcase--match nsym (nth 2 (cddr match)))
721 match))
722 ((memq (car-safe match) '(or and))
723 `(,(car match)
724 ,@(mapcar (lambda (match)
725 (pcase--app-subst-match match sym fun nsym))
726 (cdr match))))
727 ((memq match '(:pcase--succeed :pcase--fail)) match)
728 (t (error "Uknown MATCH %s" match))))
730 (defun pcase--app-subst-rest (rest sym fun nsym)
731 (mapcar (lambda (branch)
732 `(,(pcase--app-subst-match (car branch) sym fun nsym)
733 ,@(cdr branch)))
734 rest))
736 (defsubst pcase--mark-used (sym)
737 ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
738 (if (symbolp sym) (put sym 'pcase-used t)))
740 (defmacro pcase--flip (fun arg1 arg2)
741 "Helper function, used internally to avoid (funcall (lambda ...) ...)."
742 (declare (debug (sexp body)))
743 `(,fun ,arg2 ,arg1))
745 (defun pcase--funcall (fun arg vars)
746 "Build a function call to FUN with arg ARG."
747 (if (symbolp fun)
748 `(,fun ,arg)
749 (let* (;; `env' is an upper bound on the bindings we need.
750 (env (mapcar (lambda (x) (list (car x) (cdr x)))
751 (pcase--fgrep vars fun)))
752 (call (progn
753 (when (assq arg env)
754 ;; `arg' is shadowed by `env'.
755 (let ((newsym (gensym "x")))
756 (push (list newsym arg) env)
757 (setq arg newsym)))
758 (if (functionp fun)
759 `(funcall #',fun ,arg)
760 `(,@fun ,arg)))))
761 (if (null env)
762 call
763 ;; Let's not replace `vars' in `fun' since it's
764 ;; too difficult to do it right, instead just
765 ;; let-bind `vars' around `fun'.
766 `(let* ,env ,call)))))
768 (defun pcase--eval (exp vars)
769 "Build an expression that will evaluate EXP."
770 (let* ((found (assq exp vars)))
771 (if found (cdr found)
772 (let* ((env (pcase--fgrep vars exp)))
773 (if env
774 (macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x)))
775 env)
776 exp)
777 exp)))))
779 ;; It's very tempting to use `pcase' below, tho obviously, it'd create
780 ;; bootstrapping problems.
781 (defun pcase--u1 (matches code vars rest)
782 "Return code that runs CODE (with VARS) if MATCHES match.
783 Otherwise, it defers to REST which is a list of branches of the form
784 \(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
785 ;; Depending on the order in which we choose to check each of the MATCHES,
786 ;; the resulting tree may be smaller or bigger. So in general, we'd want
787 ;; to be careful to chose the "optimal" order. But predicate
788 ;; patterns make this harder because they create dependencies
789 ;; between matches. So we don't bother trying to reorder anything.
790 (cond
791 ((null matches) (funcall code vars))
792 ((eq :pcase--fail (car matches)) (pcase--u rest))
793 ((eq :pcase--succeed (car matches))
794 (pcase--u1 (cdr matches) code vars rest))
795 ((eq 'and (caar matches))
796 (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
797 ((eq 'or (caar matches))
798 (let* ((alts (cdar matches))
799 (var (if (eq (caar alts) 'match) (cadr (car alts))))
800 (simples '()) (others '()) (mem-fun 'memq))
801 (when var
802 (dolist (alt alts)
803 (if (and (eq (car alt) 'match) (eq var (cadr alt))
804 (let ((upat (cddr alt)))
805 (eq (car-safe upat) 'quote)))
806 (let ((val (cadr (cddr alt))))
807 (cond ((integerp val)
808 (when (eq mem-fun 'memq)
809 (setq mem-fun 'memql)))
810 ((not (symbolp val))
811 (setq mem-fun 'member)))
812 (push val simples))
813 (push alt others))))
814 (cond
815 ((null alts) (error "Please avoid it") (pcase--u rest))
816 ;; Yes, we can use `memql' (or `member')!
817 ((> (length simples) 1)
818 (pcase--u1 (cons `(match ,var
819 . (pred (pcase--flip ,mem-fun ',simples)))
820 (cdr matches))
821 code vars
822 (if (null others) rest
823 (cons (cons
824 (pcase--and (if (cdr others)
825 (cons 'or (nreverse others))
826 (car others))
827 (cdr matches))
828 (cons code vars))
829 rest))))
831 (pcase--u1 (cons (pop alts) (cdr matches)) code vars
832 (if (null alts) (progn (error "Please avoid it") rest)
833 (cons (cons
834 (pcase--and (if (cdr alts)
835 (cons 'or alts) (car alts))
836 (cdr matches))
837 (cons code vars))
838 rest)))))))
839 ((eq 'match (caar matches))
840 (let* ((popmatches (pop matches))
841 (_op (car popmatches)) (cdrpopmatches (cdr popmatches))
842 (sym (car cdrpopmatches))
843 (upat (cdr cdrpopmatches)))
844 (cond
845 ((memq upat '(t _))
846 (let ((code (pcase--u1 matches code vars rest)))
847 (if (eq upat '_) code
848 (macroexp--warn-and-return
849 "Pattern t is deprecated. Use `_' instead"
850 code))))
851 ((eq upat 'pcase--dontcare) :pcase--dontcare)
852 ((memq (car-safe upat) '(guard pred))
853 (if (eq (car upat) 'pred) (pcase--mark-used sym))
854 (let* ((splitrest
855 (pcase--split-rest
856 sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
857 (then-rest (car splitrest))
858 (else-rest (cdr splitrest)))
859 (pcase--if (if (eq (car upat) 'pred)
860 (pcase--funcall (cadr upat) sym vars)
861 (pcase--eval (cadr upat) vars))
862 (pcase--u1 matches code vars then-rest)
863 (pcase--u else-rest))))
864 ((and (symbolp upat) upat)
865 (pcase--mark-used sym)
866 (if (not (assq upat vars))
867 (pcase--u1 matches code (cons (cons upat sym) vars) rest)
868 ;; Non-linear pattern. Turn it into an `eq' test.
869 (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars)))))
870 matches)
871 code vars rest)))
872 ((eq (car-safe upat) 'let)
873 ;; A upat of the form (let VAR EXP).
874 ;; (pcase--u1 matches code
875 ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
876 (macroexp-let2
877 macroexp-copyable-p sym
878 (pcase--eval (nth 2 upat) vars)
879 (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
880 code vars rest)))
881 ((eq (car-safe upat) 'app)
882 ;; A upat of the form (app FUN PAT)
883 (pcase--mark-used sym)
884 (let* ((fun (nth 1 upat))
885 (nsym (gensym "x"))
886 (body
887 ;; We don't change `matches' to reuse the newly computed value,
888 ;; because we assume there shouldn't be such redundancy in there.
889 (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches)
890 code vars
891 (pcase--app-subst-rest rest sym fun nsym))))
892 (if (not (get nsym 'pcase-used))
893 body
894 (macroexp-let*
895 `((,nsym ,(pcase--funcall fun sym vars)))
896 body))))
897 ((eq (car-safe upat) 'quote)
898 (pcase--mark-used sym)
899 (let* ((val (cadr upat))
900 (splitrest (pcase--split-rest
901 sym (lambda (pat) (pcase--split-equal val pat)) rest))
902 (then-rest (car splitrest))
903 (else-rest (cdr splitrest)))
904 (pcase--if (cond
905 ((null val) `(null ,sym))
906 ((integerp val) `(eql ,sym ,val))
907 ((symbolp val)
908 (if (pcase--self-quoting-p val)
909 `(eq ,sym ,val)
910 `(eq ,sym ',val)))
911 (t `(equal ,sym ',val)))
912 (pcase--u1 matches code vars then-rest)
913 (pcase--u else-rest))))
914 ((eq (car-safe upat) 'not)
915 ;; FIXME: The implementation below is naive and results in
916 ;; inefficient code.
917 ;; To make it work right, we would need to turn pcase--u1's
918 ;; `code' and `vars' into a single argument of the same form as
919 ;; `rest'. We would also need to split this new `then-rest' argument
920 ;; for every test (currently we don't bother to do it since
921 ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
922 ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
923 ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
924 (pcase--u1 `((match ,sym . ,(cadr upat)))
925 ;; FIXME: This codegen is not careful to share its
926 ;; code if used several times: code blow up is likely.
927 (lambda (_vars)
928 ;; `vars' will likely contain bindings which are
929 ;; not always available in other paths to
930 ;; `rest', so there' no point trying to pass
931 ;; them down.
932 (pcase--u rest))
933 vars
934 (list `((and . ,matches) ,code . ,vars))))
935 (t (error "Unknown pattern `%S'" upat)))))
936 (t (error "Incorrect MATCH %S" (car matches)))))
938 (def-edebug-spec
939 pcase-QPAT
940 ;; Cf. edebug spec for `backquote-form' in edebug.el.
941 (&or ("," pcase-PAT)
942 (pcase-QPAT [&rest [&not ","] pcase-QPAT]
943 . [&or nil pcase-QPAT])
944 (vector &rest pcase-QPAT)
945 sexp))
947 (pcase-defmacro \` (qpat)
948 "Backquote-style pcase patterns: \\=`QPAT
949 QPAT can take the following forms:
950 (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
951 [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match
952 its 0..(n-1)th elements, respectively.
953 ,PAT matches if the `pcase' pattern PAT matches.
954 SYMBOL matches if EXPVAL is `equal' to SYMBOL.
955 KEYWORD likewise for KEYWORD.
956 NUMBER likewise for NUMBER.
957 STRING likewise for STRING.
959 The list or vector QPAT is a template. The predicate formed
960 by a backquote-style pattern is a combination of those
961 formed by any sub-patterns, wrapped in a top-level condition:
962 EXPVAL must be \"congruent\" with the template. For example:
964 \\=`(technical ,forum)
966 The predicate is the logical-AND of:
967 - Is EXPVAL a list of two elements?
968 - Is the first element the symbol `technical'?
969 - True! (The second element can be anything, and for the sake
970 of the body forms, its value is bound to the symbol `forum'.)"
971 (declare (debug (pcase-QPAT)))
972 (cond
973 ((eq (car-safe qpat) '\,) (cadr qpat))
974 ((vectorp qpat)
975 `(and (pred vectorp)
976 (app length ,(length qpat))
977 ,@(let ((upats nil))
978 (dotimes (i (length qpat))
979 (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
980 upats))
981 (nreverse upats))))
982 ((consp qpat)
983 `(and (pred consp)
984 (app car ,(list '\` (car qpat)))
985 (app cdr ,(list '\` (cdr qpat)))))
986 ((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat)
987 ;; In all other cases just raise an error so we can't break
988 ;; backward compatibility when adding \` support for other
989 ;; compounded values that are not `consp'
990 (t (error "Unknown QPAT: %S" qpat))))
992 (provide 'pcase)
993 ;;; pcase.el ends here