* lisp/net/shr.el (shr-insert-document): Explain why bidi-display-reordering
[emacs.git] / lisp / emacs-lisp / pcase.el
blob006517db7595d00e7af67aef5bb590dfa3fb6794
1 ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
3 ;; Copyright (C) 2010-2021 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6 ;; Keywords: extensions
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 ;; - Allow to provide new `pcase--split-<foo>' thingy.
31 ;; - provide something like (setq VAR) so a var can be set rather than
32 ;; let-bound.
33 ;; - provide a way to continue matching to subsequent cases
34 ;; (e.g. Like Racket's (=> ID).
35 ;; - try and be more clever to reduce the size of the decision tree, and
36 ;; to reduce the number of leaves that need to be turned into functions:
37 ;; - first, do the tests shared by all remaining branches (it will have
38 ;; to be performed anyway, so better do it first so it's shared).
39 ;; - then choose the test that discriminates more (?).
40 ;; - provide Agda's `with' (along with its `...' companion).
41 ;; - implement (not PAT). This might require a significant redesign.
42 ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
43 ;; generate a lex-style DFA to decide whether to run E1 or E2.
45 ;;; Code:
47 (require 'macroexp)
49 ;; Macro-expansion of pcase is reasonably fast, so it's not a problem
50 ;; when byte-compiling a file, but when interpreting the code, if the pcase
51 ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
52 ;; memoize previous macro expansions to try and avoid recomputing them
53 ;; over and over again.
54 ;; FIXME: Now that macroexpansion is also performed when loading an interpreted
55 ;; file, this is not a real problem any more.
56 (defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
57 ;; (defconst pcase--memoize (make-hash-table :test 'eq))
58 ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
59 ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
61 (defconst pcase--dontcare-upats '(t _ pcase--dontcare))
63 (defvar pcase--dontwarn-upats '(pcase--dontcare))
65 (def-edebug-elem-spec 'pcase-PAT
66 '(&or (&interpose symbolp pcase--edebug-match-pat-args) sexp))
68 (def-edebug-elem-spec 'pcase-FUN
69 '(&or lambda-expr
70 ;; Punt on macros/special forms.
71 (functionp &rest form)
72 sexp))
74 ;; Only called from edebug.
75 (declare-function edebug-get-spec "edebug" (symbol))
76 (defun pcase--edebug-match-pat-args (head pf)
77 ;; (cl-assert (null (cdr head)))
78 (setq head (car head))
79 (or (alist-get head '((quote sexp)
80 (or &rest pcase-PAT)
81 (and &rest pcase-PAT)
82 (guard form)
83 (pred &or ("not" pcase-FUN) pcase-FUN)
84 (app pcase-FUN pcase-PAT)))
85 (let ((me (pcase--get-macroexpander head)))
86 (funcall pf (and me (symbolp me) (edebug-get-spec me))))))
88 (defun pcase--get-macroexpander (s)
89 "Return the macroexpander for pcase pattern head S, or nil"
90 (get s 'pcase-macroexpander))
92 ;;;###autoload
93 (defmacro pcase (exp &rest cases)
94 ;; FIXME: Add some "global pattern" to wrap every case?
95 ;; Could be used to wrap all cases in a `
96 "Evaluate EXP to get EXPVAL; try passing control to one of CASES.
97 CASES is a list of elements of the form (PATTERN CODE...).
98 For the first CASE whose PATTERN \"matches\" EXPVAL,
99 evaluate its CODE..., and return the value of the last form.
100 If no CASE has a PATTERN that matches, return nil.
102 Each PATTERN expands, in essence, to a predicate to call
103 on EXPVAL. When the return value of that call is non-nil,
104 PATTERN matches. PATTERN can take one of the forms:
106 _ matches anything.
107 \\='VAL matches if EXPVAL is `equal' to VAL.
108 KEYWORD shorthand for \\='KEYWORD
109 INTEGER shorthand for \\='INTEGER
110 STRING shorthand for \\='STRING
111 SYMBOL matches anything and binds it to SYMBOL.
112 If a SYMBOL is used twice in the same pattern
113 the second occurrence becomes an `eq'uality test.
114 (pred FUN) matches if FUN called on EXPVAL returns non-nil.
115 (pred (not FUN)) matches if FUN called on EXPVAL returns nil.
116 (app FUN PAT) matches if FUN called on EXPVAL matches PAT.
117 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
118 (and PAT...) matches if all the patterns match.
119 (or PAT...) matches if any of the patterns matches.
121 FUN in `pred' and `app' can take one of the forms:
122 SYMBOL or (lambda ARGS BODY)
123 call it with one argument
124 (F ARG1 .. ARGn)
125 call F with ARG1..ARGn and EXPVAL as n+1'th argument
127 FUN, BOOLEXP, and subsequent PAT can refer to variables
128 bound earlier in the pattern by a SYMBOL pattern.
130 Additional patterns can be defined using `pcase-defmacro'.
132 See Info node `(elisp) Pattern-Matching Conditional' in the
133 Emacs Lisp manual for more information and examples."
134 (declare (indent 1) (debug (form &rest (pcase-PAT body))))
135 ;; We want to use a weak hash table as a cache, but the key will unavoidably
136 ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
137 ;; we're called so it'll be immediately GC'd. So we use (car cases) as key
138 ;; which does come straight from the source code and should hence not be GC'd
139 ;; so easily.
140 (let ((data (gethash (car cases) pcase--memoize)))
141 ;; data = (EXP CASES . EXPANSION)
142 (if (and (equal exp (car data)) (equal cases (cadr data)))
143 ;; We have the right expansion.
144 (cddr data)
145 ;; (when (gethash (car cases) pcase--memoize-1)
146 ;; (message "pcase-memoize failed because of weak key!!"))
147 ;; (when (gethash (car cases) pcase--memoize-2)
148 ;; (message "pcase-memoize failed because of eq test on %S"
149 ;; (car cases)))
150 ;; (when data
151 ;; (message "pcase-memoize: equal first branch, yet different"))
152 (let ((expansion (pcase--expand exp cases)))
153 (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
154 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
155 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
156 expansion))))
158 (declare-function help-fns--signature "help-fns"
159 (function doc real-def real-function buffer))
161 ;; FIXME: Obviously, this will collide with nadvice's use of
162 ;; function-documentation if we happen to advise `pcase'.
163 ;;;###autoload
164 (put 'pcase 'function-documentation '(pcase--make-docstring))
165 ;;;###autoload
166 (defun pcase--make-docstring ()
167 (let* ((main (documentation (symbol-function 'pcase) 'raw))
168 (ud (help-split-fundoc main 'pcase)))
169 ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works,
170 ;; where cl-lib is anything using pcase-defmacro.
171 (require 'help-fns)
172 (with-temp-buffer
173 (insert (or (cdr ud) main))
174 ;; Presentation Note: For conceptual continuity, we guarantee
175 ;; that backquote doc immediately follows main pcase doc.
176 ;; (The order of the other extensions is unimportant.)
177 (let (more)
178 ;; Collect all the extensions.
179 (mapatoms (lambda (symbol)
180 (let ((me (pcase--get-macroexpander symbol)))
181 (when me
182 (push (cons symbol me)
183 more)))))
184 ;; Ensure backquote is first.
185 (let ((x (assq '\` more)))
186 (setq more (cons x (delq x more))))
187 ;; Do the output.
188 (while more
189 (let* ((pair (pop more))
190 (symbol (car pair))
191 (me (cdr pair))
192 (doc (documentation me 'raw)))
193 (insert "\n\n-- ")
194 (setq doc (help-fns--signature symbol doc me
195 (indirect-function me)
196 nil))
197 (insert "\n" (or doc "Not documented.")))))
198 (let ((combined-doc (buffer-string)))
199 (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
201 ;;;###autoload
202 (defmacro pcase-exhaustive (exp &rest cases)
203 "The exhaustive version of `pcase' (which see).
204 If EXP fails to match any of the patterns in CASES, an error is signaled."
205 (declare (indent 1) (debug pcase))
206 (let* ((x (gensym "x"))
207 (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
208 (pcase--expand
209 ;; FIXME: Could we add the FILE:LINE data in the error message?
210 ;; FILE is available from `macroexp-file-name'.
211 exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
213 ;;;###autoload
214 (defmacro pcase-lambda (lambda-list &rest body)
215 "Like `lambda' but allow each argument to be a pattern.
216 I.e. accepts the usual &optional and &rest keywords, but every
217 formal argument can be any pattern accepted by `pcase' (a mere
218 variable name being but a special case of it)."
219 (declare (doc-string 2) (indent defun)
220 (debug (&define (&rest pcase-PAT) lambda-doc def-body)))
221 (let* ((bindings ())
222 (parsed-body (macroexp-parse-body body))
223 (args (mapcar (lambda (pat)
224 (if (symbolp pat)
225 ;; Simple vars and &rest/&optional are just passed
226 ;; through unchanged.
228 (let ((arg (make-symbol
229 (format "arg%s" (length bindings)))))
230 (push `(,pat ,arg) bindings)
231 arg)))
232 lambda-list)))
233 `(lambda ,args ,@(car parsed-body)
234 (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body)))))
236 (defun pcase--let* (bindings body)
237 (cond
238 ((null bindings) (macroexp-progn body))
239 ((pcase--trivial-upat-p (caar bindings))
240 (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
242 (let ((binding (pop bindings)))
243 (pcase--expand
244 (cadr binding)
245 `((,(car binding) ,(pcase--let* bindings body))
246 ;; We can either signal an error here, or just use `pcase--dontcare'
247 ;; which generates more efficient code. In practice, if we use
248 ;; `pcase--dontcare' we will still often get an error and the few
249 ;; cases where we don't do not matter that much, so
250 ;; it's a better choice.
251 (pcase--dontcare nil)))))))
253 ;;;###autoload
254 (defmacro pcase-let* (bindings &rest body)
255 "Like `let*', but supports destructuring BINDINGS using `pcase' patterns.
256 As with `pcase-let', BINDINGS are of the form (PATTERN EXP), but the
257 EXP in each binding in BINDINGS can use the results of the destructuring
258 bindings that precede it in BINDINGS' order.
260 Each EXP should match (i.e. be of compatible structure) to its
261 respective PATTERN; a mismatch may signal an error or may go
262 undetected, binding variables to arbitrary values, such as nil."
263 (declare (indent 1)
264 (debug ((&rest (pcase-PAT &optional form)) body)))
265 (let ((cached (gethash bindings pcase--memoize)))
266 ;; cached = (BODY . EXPANSION)
267 (if (equal (car cached) body)
268 (cdr cached)
269 (let ((expansion (pcase--let* bindings body)))
270 (puthash bindings (cons body expansion) pcase--memoize)
271 expansion))))
273 ;;;###autoload
274 (defmacro pcase-let (bindings &rest body)
275 "Like `let', but supports destructuring BINDINGS using `pcase' patterns.
276 BODY should be a list of expressions, and BINDINGS should be a list of
277 bindings of the form (PATTERN EXP).
278 All EXPs are evaluated first, and then used to perform destructuring
279 bindings by matching each EXP against its respective PATTERN. Then
280 BODY is evaluated with those bindings in effect.
282 Each EXP should match (i.e. be of compatible structure) to its
283 respective PATTERN; a mismatch may signal an error or may go
284 undetected, binding variables to arbitrary values, such as nil."
285 (declare (indent 1) (debug pcase-let*))
286 (if (null (cdr bindings))
287 `(pcase-let* ,bindings ,@body)
288 (let ((matches '()))
289 (dolist (binding (prog1 bindings (setq bindings nil)))
290 (cond
291 ((memq (car binding) pcase--dontcare-upats)
292 (push (cons (make-symbol "_") (cdr binding)) bindings))
293 ((pcase--trivial-upat-p (car binding)) (push binding bindings))
295 (let ((tmpvar (make-symbol (format "x%d" (length bindings)))))
296 (push (cons tmpvar (cdr binding)) bindings)
297 (push (list (car binding) tmpvar) matches)))))
298 `(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
300 ;;;###autoload
301 (defmacro pcase-dolist (spec &rest body)
302 "Eval BODY once for each set of bindings defined by PATTERN and LIST elements.
303 PATTERN should be a `pcase' pattern describing the structure of
304 LIST elements, and LIST is a list of objects that match PATTERN,
305 i.e. have a structure that is compatible with PATTERN.
306 For each element of LIST, this macro binds the variables in
307 PATTERN to the corresponding subfields of the LIST element, and
308 then evaluates BODY with these bindings in effect. The
309 destructuring bindings of variables in PATTERN to the subfields
310 of the elements of LIST is performed as if by `pcase-let'.
311 \n(fn (PATTERN LIST) BODY...)"
312 (declare (indent 1) (debug ((pcase-PAT form) body)))
313 (if (pcase--trivial-upat-p (car spec))
314 `(dolist ,spec ,@body)
315 (let ((tmpvar (gensym "x")))
316 `(dolist (,tmpvar ,@(cdr spec))
317 (pcase-let* ((,(car spec) ,tmpvar))
318 ,@body)))))
321 (defun pcase--trivial-upat-p (upat)
322 (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
324 (defun pcase-compile-patterns (exp cases)
325 "Compile the set of patterns in CASES.
326 EXP is the expression that will be matched against the patterns.
327 CASES is a list of elements (PAT . CODEGEN)
328 where CODEGEN is a function that returns the code to use when
329 PAT matches. That code has to be in the form of a cons cell.
331 CODEGEN will be called with at least 2 arguments, VARVALS and COUNT.
332 VARVALS is a list of elements of the form (VAR VAL . RESERVED) where VAR
333 is a variable bound by the pattern and VAL is a duplicable expression
334 that returns the value this variable should be bound to.
335 If the pattern PAT uses `or', CODEGEN may be called multiple times,
336 in which case it may want to generate the code differently to avoid
337 a potential code explosion. For this reason the COUNT argument indicates
338 how many time this CODEGEN is called."
339 (macroexp-let2 macroexp-copyable-p val exp
340 (let* ((seen '())
341 (phcounter 0)
342 (main
343 (pcase--u
344 (mapcar
345 (lambda (case)
346 `(,(pcase--match val (pcase--macroexpand (car case)))
347 ,(lambda (vars)
348 (let ((prev (assq case seen)))
349 (unless prev
350 ;; Keep track of the cases that are used.
351 (push (setq prev (list case)) seen))
352 ;; Put a counter in the cdr just so that not
353 ;; all branches look identical (to avoid things
354 ;; like `macroexp--if' optimizing them too
355 ;; optimistically).
356 (let ((ph (cons 'pcase--placeholder
357 (setq phcounter (1+ phcounter)))))
358 (setcdr prev (cons (cons vars ph) (cdr prev)))
359 ph)))))
360 cases))))
361 ;; Take care of the place holders now.
362 (dolist (branch seen)
363 (let ((codegen (cdar branch))
364 (uses (cdr branch)))
365 ;; Find all the vars that are in scope (the union of the
366 ;; vars provided in each use case).
367 (let* ((allvarinfo '())
368 (_ (dolist (use uses)
369 (dolist (v (car use))
370 (let ((vi (assq (car v) allvarinfo)))
371 (if vi
372 (if (cddr v) (setcdr vi 'used))
373 (push (cons (car v) (cddr v)) allvarinfo))))))
374 (allvars (mapcar #'car allvarinfo)))
375 (dolist (use uses)
376 (let* ((vars (car use))
377 (varvals
378 (mapcar (lambda (v)
379 `(,v ,(cadr (assq v vars))
380 ,(cdr (assq v allvarinfo))))
381 allvars))
382 (placeholder (cdr use))
383 (code (funcall codegen varvals (length uses))))
384 ;; (cl-assert (eq (car placeholder) 'pcase--placeholder))
385 (setcar placeholder (car code))
386 (setcdr placeholder (cdr code)))))))
387 (dolist (case cases)
388 (unless (or (assq case seen)
389 (memq (car case) pcase--dontwarn-upats))
390 (setq main
391 (macroexp-warn-and-return
392 (format "pcase pattern %S shadowed by previous pcase pattern"
393 (car case))
394 main))))
395 main)))
397 (defun pcase--expand (exp cases)
398 ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
399 ;; (emacs-pid) exp (sxhash cases))
400 (let* ((defs ())
401 (codegen
402 (lambda (code)
403 (if (member code '(nil (nil) ('nil)))
404 (lambda (&rest _) ''nil)
405 (let ((bsym ()))
406 (lambda (varvals count &rest _)
407 (let* ((ignored-vars
408 (delq nil (mapcar (lambda (vv) (if (nth 2 vv) (car vv)))
409 varvals)))
410 (ignores (if ignored-vars
411 `((ignore . ,ignored-vars)))))
412 ;; Since we use a tree-based pattern matching
413 ;; technique, the leaves (the places that contain the
414 ;; code to run once a pattern is matched) can get
415 ;; copied a very large number of times, so to avoid
416 ;; code explosion, we need to keep track of how many
417 ;; times we've used each leaf and move it
418 ;; to a separate function if that number is too high.
419 (if (or (< count 2) (pcase--small-branch-p code))
420 `(let ,(mapcar (lambda (vv) (list (car vv) (cadr vv)))
421 varvals)
422 ;; Try and silence some of the most common
423 ;; spurious "unused var" warnings.
424 ,@ignores
425 ,@code)
426 ;; Several occurrence of this non-small branch in
427 ;; the output.
428 (unless bsym
429 (setq bsym (make-symbol
430 (format "pcase-%d" (length defs))))
431 (push `(,bsym (lambda ,(mapcar #'car varvals)
432 ,@ignores ,@code))
433 defs))
434 `(funcall ,bsym ,@(mapcar #'cadr varvals)))))))))
435 (main
436 (pcase-compile-patterns
438 (mapcar (lambda (case)
439 (cons (car case) (funcall codegen (cdr case))))
440 cases))))
441 (macroexp-let* defs main)))
443 (defun pcase--macroexpand (pat)
444 "Expands all macro-patterns in PAT."
445 (let ((head (car-safe pat)))
446 (cond
447 ((null head)
448 (if (pcase--self-quoting-p pat) `',pat pat))
449 ((memq head '(pred guard quote)) pat)
450 ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
451 ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
453 (let* ((expander (pcase--get-macroexpander head))
454 (npat (if expander (apply expander (cdr pat)))))
455 (if (null npat)
456 (error (if expander
457 "Unexpandable %s pattern: %S"
458 "Unknown %s pattern: %S")
459 head pat)
460 (pcase--macroexpand npat)))))))
462 ;;;###autoload
463 (defmacro pcase-defmacro (name args &rest body)
464 "Define a new kind of pcase PATTERN, by macro expansion.
465 Patterns of the form (NAME ...) will be expanded according
466 to this macro.
468 By convention, DOC should use \"EXPVAL\" to stand
469 for the result of evaluating EXP (first arg to `pcase').
470 \n(fn NAME ARGS [DOC] &rest BODY...)"
471 (declare (indent 2) (debug defun) (doc-string 3))
472 ;; Add the function via `fsym', so that an autoload cookie placed
473 ;; on a pcase-defmacro will cause the macro to be loaded on demand.
474 (let ((fsym (intern (format "%s--pcase-macroexpander" name)))
475 (decl (assq 'declare body)))
476 (when decl (setq body (remove decl body)))
477 `(progn
478 ;; FIXME: We use `eval-and-compile' here so that the pcase macro can be
479 ;; used in the same file where it's defined, but ideally, we should
480 ;; handle this using something similar to `overriding-plist-environment'
481 ;; but for `symbol-function' slots so compiling a file doesn't have the
482 ;; side-effect of defining the function.
483 (eval-and-compile
484 (defun ,fsym ,args ,@body))
485 (define-symbol-prop ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
486 (define-symbol-prop ',name 'pcase-macroexpander #',fsym))))
488 (defun pcase--match (val upat)
489 "Build a MATCH structure, hoisting all `or's and `and's outside."
490 (cond
491 ;; Hoist or/and patterns into or/and matches.
492 ((memq (car-safe upat) '(or and))
493 `(,(car upat)
494 ,@(mapcar (lambda (upat)
495 (pcase--match val upat))
496 (cdr upat))))
498 `(match ,val . ,upat))))
500 (defun pcase--small-branch-p (code)
501 (and (= 1 (length code))
502 (or (not (consp (car code)))
503 (let ((small t))
504 (dolist (e (car code))
505 (if (consp e) (setq small nil)))
506 small))))
508 ;; Try to use `cond' rather than a sequence of `if's, so as to reduce
509 ;; the depth of the generated tree.
510 (defun pcase--if (test then else)
511 (cond
512 ((eq else :pcase--dontcare) `(progn (ignore ,test) ,then))
513 ;; This happens very rarely. Known case:
514 ;; (pcase EXP ((and 1 pcase--dontcare) FOO))
515 ((eq then :pcase--dontcare) `(progn (ignore ,test) ,else))
516 (t (macroexp-if test then else))))
518 ;; Note about MATCH:
519 ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
520 ;; check, we want to turn all the similar patterns into ones of the form
521 ;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
522 ;; Earlier code hence used branches of the form (MATCHES . CODE) where
523 ;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
524 ;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
525 ;; no easy way to eliminate the `consp' check in such a representation.
526 ;; So we replaced the MATCHES by the MATCH below which can be made up
527 ;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
528 ;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
529 ;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
530 ;; The downside is that we now have `or' and `and' both in MATCH and
531 ;; in PAT, so there are different equivalent representations and we
532 ;; need to handle them all. We do not try to systematically
533 ;; canonicalize them to one form over another, but we do occasionally
534 ;; turn one into the other.
536 (defun pcase--u (branches)
537 "Expand matcher for rules BRANCHES.
538 Each BRANCH has the form (MATCH CODE . VARS) where
539 CODE is the code generator for that branch.
540 MATCH is the pattern that needs to be matched, of the form:
541 (match VAR . PAT)
542 (and MATCH ...)
543 (or MATCH ...)
544 VARS is the set of vars already bound by earlier matches.
545 It is a list of (NAME VAL . USED) where NAME is the variable's symbol,
546 VAL is the expression to which it should be bound and USED is a boolean
547 recording whether the var has been referenced by earlier parts of the match."
548 (when (setq branches (delq nil branches))
549 (let* ((carbranch (car branches))
550 (match (car carbranch)) (cdarbranch (cdr carbranch))
551 (code (car cdarbranch))
552 (vars (cdr cdarbranch)))
553 (pcase--u1 (list match) code vars (cdr branches)))))
555 (defun pcase--and (match matches)
556 (if matches `(and ,match ,@matches) match))
558 (defconst pcase-mutually-exclusive-predicates
559 '((symbolp . integerp)
560 (symbolp . numberp)
561 (symbolp . consp)
562 (symbolp . arrayp)
563 (symbolp . vectorp)
564 (symbolp . stringp)
565 (symbolp . byte-code-function-p)
566 (symbolp . recordp)
567 (integerp . consp)
568 (integerp . arrayp)
569 (integerp . vectorp)
570 (integerp . stringp)
571 (integerp . byte-code-function-p)
572 (integerp . recordp)
573 (numberp . consp)
574 (numberp . arrayp)
575 (numberp . vectorp)
576 (numberp . stringp)
577 (numberp . byte-code-function-p)
578 (numberp . recordp)
579 (consp . arrayp)
580 (consp . atom)
581 (consp . vectorp)
582 (consp . stringp)
583 (consp . byte-code-function-p)
584 (consp . recordp)
585 (arrayp . byte-code-function-p)
586 (vectorp . byte-code-function-p)
587 (vectorp . recordp)
588 (stringp . vectorp)
589 (stringp . recordp)
590 (stringp . byte-code-function-p)))
592 (defun pcase--mutually-exclusive-p (pred1 pred2)
593 (or (member (cons pred1 pred2)
594 pcase-mutually-exclusive-predicates)
595 (member (cons pred2 pred1)
596 pcase-mutually-exclusive-predicates)))
598 (defun pcase--split-match (sym splitter match)
599 (cond
600 ((eq (car-safe match) 'match)
601 (if (not (eq sym (cadr match)))
602 (cons match match)
603 (let ((res (funcall splitter (cddr match))))
604 (cons (or (car res) match) (or (cdr res) match)))))
605 ((memq (car-safe match) '(or and))
606 (let ((then-alts '())
607 (else-alts '())
608 (neutral-elem (if (eq 'or (car match))
609 :pcase--fail :pcase--succeed))
610 (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail)))
611 (dolist (alt (cdr match))
612 (let ((split (pcase--split-match sym splitter alt)))
613 (unless (eq (car split) neutral-elem)
614 (push (car split) then-alts))
615 (unless (eq (cdr split) neutral-elem)
616 (push (cdr split) else-alts))))
617 (cons (cond ((memq zero-elem then-alts) zero-elem)
618 ((null then-alts) neutral-elem)
619 ((null (cdr then-alts)) (car then-alts))
620 (t (cons (car match) (nreverse then-alts))))
621 (cond ((memq zero-elem else-alts) zero-elem)
622 ((null else-alts) neutral-elem)
623 ((null (cdr else-alts)) (car else-alts))
624 (t (cons (car match) (nreverse else-alts)))))))
625 ((memq match '(:pcase--succeed :pcase--fail)) (cons match match))
626 (t (error "Unknown MATCH %s" match))))
628 (defun pcase--split-rest (sym splitter rest)
629 (let ((then-rest '())
630 (else-rest '()))
631 (dolist (branch rest)
632 (let* ((match (car branch))
633 (code&vars (cdr branch))
634 (split
635 (pcase--split-match sym splitter match)))
636 (unless (eq (car split) :pcase--fail)
637 (push (cons (car split) code&vars) then-rest))
638 (unless (eq (cdr split) :pcase--fail)
639 (push (cons (cdr split) code&vars) else-rest))))
640 (cons (nreverse then-rest) (nreverse else-rest))))
642 (defun pcase--split-equal (elem pat)
643 (cond
644 ;; The same match will give the same result.
645 ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem))
646 '(:pcase--succeed . :pcase--fail))
647 ;; A different match will fail if this one succeeds.
648 ((and (eq (car-safe pat) 'quote)
649 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
650 ;; (consp (cadr pat)))
652 '(:pcase--fail . nil))
653 ((and (eq (car-safe pat) 'pred)
654 (symbolp (cadr pat))
655 (get (cadr pat) 'side-effect-free))
656 (ignore-errors
657 (if (funcall (cadr pat) elem)
658 '(:pcase--succeed . nil)
659 '(:pcase--fail . nil))))))
661 (defun pcase--split-member (elems pat)
662 ;; FIXME: The new pred-based member code doesn't do these optimizations!
663 ;; Based on pcase--split-equal.
664 (cond
665 ;; The same match (or a match of membership in a superset) will
666 ;; give the same result, but we don't know how to check it.
667 ;; (???
668 ;; '(:pcase--succeed . nil))
669 ;; A match for one of the elements may succeed or fail.
670 ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems))
671 nil)
672 ;; A different match will fail if this one succeeds.
673 ((and (eq (car-safe pat) 'quote)
674 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
675 ;; (consp (cadr pat)))
677 '(:pcase--fail . nil))
678 ((and (eq (car-safe pat) 'pred)
679 (symbolp (cadr pat))
680 (get (cadr pat) 'side-effect-free)
681 (ignore-errors
682 (let ((p (cadr pat)) (all t))
683 (dolist (elem elems)
684 (unless (funcall p elem) (setq all nil)))
685 all)))
686 '(:pcase--succeed . nil))))
688 (defun pcase--split-pred (vars upat pat)
689 "Indicate the overlap or mutual-exclusion between UPAT and PAT.
690 More specifically returns a pair (A . B) where A indicates whether PAT
691 can match when UPAT has matched, and B does the same for the case
692 where UPAT failed to match.
693 A and B can be one of:
694 - nil if we don't know
695 - `:pcase--fail' if UPAT match's result implies that PAT can't match
696 - `:pcase--succeed' if UPAT match's result implies that PAT matches"
697 (let (test)
698 (cond
699 ((and (equal upat pat)
700 ;; For predicates like (pred (> a)), two such predicates may
701 ;; actually refer to different variables `a'.
702 (or (and (eq 'pred (car upat)) (symbolp (cadr upat)))
703 ;; FIXME: `vars' gives us the environment in which `upat' will
704 ;; run, but we don't have the environment in which `pat' will
705 ;; run, so we can't do a reliable verification. But let's try
706 ;; and catch at least the easy cases such as (bug#14773).
707 (not (macroexp--fgrep vars (cadr upat)))))
708 '(:pcase--succeed . :pcase--fail))
709 ;; In case PAT is of the form (pred (not PRED))
710 ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat))))
711 (let* ((test (cadr (cadr pat)))
712 (res (pcase--split-pred vars upat `(pred ,test)))
713 (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail)
714 ((eq x :pcase--fail) :pcase--succeed)))))
715 (cons (funcall reverse (car res))
716 (funcall reverse (cdr res)))))
717 ;; All the rest below presumes UPAT is of the form (pred ...).
718 ((not (eq 'pred (car upat))) nil)
719 ;; In case UPAT is of the form (pred (not PRED))
720 ((eq 'not (car-safe (cadr upat)))
721 (let* ((test (cadr (cadr upat)))
722 (res (pcase--split-pred vars `(pred ,test) pat)))
723 (cons (cdr res) (car res))))
724 ((let ((otherpred
725 (cond ((eq 'pred (car-safe pat)) (cadr pat))
726 ((not (eq 'quote (car-safe pat))) nil)
727 ((consp (cadr pat)) #'consp)
728 ((stringp (cadr pat)) #'stringp)
729 ((vectorp (cadr pat)) #'vectorp)
730 ((byte-code-function-p (cadr pat))
731 #'byte-code-function-p))))
732 (pcase--mutually-exclusive-p (cadr upat) otherpred))
733 '(:pcase--fail . nil))
734 ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
735 ;; try and preserve the info we get from that memq test.
736 ((and (eq 'pcase--flip (car-safe (cadr upat)))
737 (memq (cadr (cadr upat)) '(memq member memql))
738 (eq 'quote (car-safe (nth 2 (cadr upat))))
739 (eq 'quote (car-safe pat)))
740 (let ((set (cadr (nth 2 (cadr upat)))))
741 (if (member (cadr pat) set)
742 '(nil . :pcase--fail)
743 '(:pcase--fail . nil))))
744 ((and (eq 'quote (car-safe pat))
745 (symbolp (cadr upat))
746 (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
747 (get (cadr upat) 'side-effect-free)
748 (ignore-errors
749 (setq test (list (funcall (cadr upat) (cadr pat))))))
750 (if (car test)
751 '(nil . :pcase--fail)
752 '(:pcase--fail . nil))))))
754 (defun pcase--self-quoting-p (upat)
755 (or (keywordp upat) (integerp upat) (stringp upat)))
757 (defun pcase--app-subst-match (match sym fun nsym)
758 (cond
759 ((eq (car-safe match) 'match)
760 (if (and (eq sym (cadr match))
761 (eq 'app (car-safe (cddr match)))
762 (equal fun (nth 1 (cddr match))))
763 (pcase--match nsym (nth 2 (cddr match)))
764 match))
765 ((memq (car-safe match) '(or and))
766 `(,(car match)
767 ,@(mapcar (lambda (match)
768 (pcase--app-subst-match match sym fun nsym))
769 (cdr match))))
770 ((memq match '(:pcase--succeed :pcase--fail)) match)
771 (t (error "Unknown MATCH %s" match))))
773 (defun pcase--app-subst-rest (rest sym fun nsym)
774 (mapcar (lambda (branch)
775 `(,(pcase--app-subst-match (car branch) sym fun nsym)
776 ,@(cdr branch)))
777 rest))
779 (defsubst pcase--mark-used (sym)
780 ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
781 (if (symbolp sym) (put sym 'pcase-used t)))
783 (defmacro pcase--flip (fun arg1 arg2)
784 "Helper function, used internally to avoid (funcall (lambda ...) ...)."
785 (declare (debug (sexp body)))
786 `(,fun ,arg2 ,arg1))
788 (defun pcase--funcall (fun arg vars)
789 "Build a function call to FUN with arg ARG."
790 (cond
791 ((symbolp fun) `(,fun ,arg))
792 ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars)))
794 (let* (;; `env' is hopefully an upper bound on the bindings we need,
795 ;; FIXME: See bug#46786 for a counter example :-(
796 (env (mapcar (lambda (x)
797 (setcdr (cdr x) 'used)
798 (list (car x) (cadr x)))
799 (macroexp--fgrep vars fun)))
800 (call (progn
801 (when (assq arg env)
802 ;; `arg' is shadowed by `env'.
803 (let ((newsym (gensym "x")))
804 (push (list newsym arg) env)
805 (setq arg newsym)))
806 (if (or (functionp fun) (not (consp fun)))
807 `(funcall #',fun ,arg)
808 `(,@fun ,arg)))))
809 (if (null env)
810 call
811 ;; Let's not replace `vars' in `fun' since it's
812 ;; too difficult to do it right, instead just
813 ;; let-bind `vars' around `fun'.
814 `(let* ,env ,call))))))
816 (defun pcase--eval (exp vars)
817 "Build an expression that will evaluate EXP."
818 (let* ((found (assq exp vars)))
819 (if found (progn (setcdr (cdr found) 'used) (cadr found))
820 (let* ((env (macroexp--fgrep vars exp)))
821 (if env
822 (macroexp-let* (mapcar (lambda (x)
823 (setcdr (cdr x) 'used)
824 (list (car x) (cadr x)))
825 env)
826 exp)
827 exp)))))
829 ;; It's very tempting to use `pcase' below, tho obviously, it'd create
830 ;; bootstrapping problems.
831 (defun pcase--u1 (matches code vars rest)
832 "Return code that runs CODE (with VARS) if MATCHES match.
833 Otherwise, it defers to REST which is a list of branches of the form
834 \(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
835 ;; Depending on the order in which we choose to check each of the MATCHES,
836 ;; the resulting tree may be smaller or bigger. So in general, we'd want
837 ;; to be careful to choose the "optimal" order. But predicate
838 ;; patterns make this harder because they create dependencies
839 ;; between matches. So we don't bother trying to reorder anything.
840 (cond
841 ((null matches) (funcall code vars))
842 ((eq :pcase--fail (car matches)) (pcase--u rest))
843 ((eq :pcase--succeed (car matches))
844 (pcase--u1 (cdr matches) code vars rest))
845 ((eq 'and (caar matches))
846 (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
847 ((eq 'or (caar matches))
848 (let* ((alts (cdar matches))
849 (var (if (eq (caar alts) 'match) (cadr (car alts))))
850 (simples '()) (others '()) (mem-fun 'memq))
851 (when var
852 (dolist (alt alts)
853 (if (and (eq (car alt) 'match) (eq var (cadr alt))
854 (let ((upat (cddr alt)))
855 (eq (car-safe upat) 'quote)))
856 (let ((val (cadr (cddr alt))))
857 (cond ((integerp val)
858 (when (eq mem-fun 'memq)
859 (setq mem-fun 'memql)))
860 ((not (symbolp val))
861 (setq mem-fun 'member)))
862 (push val simples))
863 (push alt others))))
864 (cond
865 ((null alts) (error "Please avoid it") (pcase--u rest))
866 ;; Yes, we can use `memql' (or `member')!
867 ((> (length simples) 1)
868 (pcase--u1 (cons `(match ,var
869 . (pred (pcase--flip ,mem-fun ',simples)))
870 (cdr matches))
871 code vars
872 (if (null others) rest
873 (cons (cons
874 (pcase--and (if (cdr others)
875 (cons 'or (nreverse others))
876 (car others))
877 (cdr matches))
878 (cons code vars))
879 rest))))
881 (pcase--u1 (cons (pop alts) (cdr matches)) code vars
882 (if (null alts) (progn (error "Please avoid it") rest)
883 (cons (cons
884 (pcase--and (if (cdr alts)
885 (cons 'or alts) (car alts))
886 (cdr matches))
887 (cons code vars))
888 rest)))))))
889 ((eq 'match (caar matches))
890 (let* ((popmatches (pop matches))
891 (_op (car popmatches)) (cdrpopmatches (cdr popmatches))
892 (sym (car cdrpopmatches))
893 (upat (cdr cdrpopmatches)))
894 (cond
895 ((memq upat '(t _))
896 (let ((code (pcase--u1 matches code vars rest)))
897 (if (eq upat '_) code
898 (macroexp-warn-and-return
899 "Pattern t is deprecated. Use `_' instead"
900 code))))
901 ((eq upat 'pcase--dontcare) :pcase--dontcare)
902 ((memq (car-safe upat) '(guard pred))
903 (if (eq (car upat) 'pred) (pcase--mark-used sym))
904 (let* ((splitrest
905 (pcase--split-rest
906 sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
907 (then-rest (car splitrest))
908 (else-rest (cdr splitrest)))
909 (pcase--if (if (eq (car upat) 'pred)
910 (pcase--funcall (cadr upat) sym vars)
911 (pcase--eval (cadr upat) vars))
912 (pcase--u1 matches code vars then-rest)
913 (pcase--u else-rest))))
914 ((and (symbolp upat) upat)
915 (pcase--mark-used sym)
916 (let ((v (assq upat vars)))
917 (if (not v)
918 (pcase--u1 matches code (cons (list upat sym) vars) rest)
919 ;; Non-linear pattern. Turn it into an `eq' test.
920 (setcdr (cdr v) 'used)
921 (pcase--u1 (cons `(match ,sym . (pred (eql ,(cadr v))))
922 matches)
923 code vars rest))))
924 ((eq (car-safe upat) 'app)
925 ;; A upat of the form (app FUN PAT)
926 (pcase--mark-used sym)
927 (let* ((fun (nth 1 upat))
928 (nsym (gensym "x"))
929 (body
930 ;; We don't change `matches' to reuse the newly computed value,
931 ;; because we assume there shouldn't be such redundancy in there.
932 (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches)
933 code vars
934 (pcase--app-subst-rest rest sym fun nsym))))
935 (if (not (get nsym 'pcase-used))
936 body
937 (macroexp-let*
938 `((,nsym ,(pcase--funcall fun sym vars)))
939 body))))
940 ((eq (car-safe upat) 'quote)
941 (pcase--mark-used sym)
942 (let* ((val (cadr upat))
943 (splitrest (pcase--split-rest
944 sym (lambda (pat) (pcase--split-equal val pat)) rest))
945 (then-rest (car splitrest))
946 (else-rest (cdr splitrest)))
947 (pcase--if (cond
948 ((null val) `(null ,sym))
949 ((integerp val) `(eql ,sym ,val))
950 ((symbolp val)
951 (if (pcase--self-quoting-p val)
952 `(eq ,sym ,val)
953 `(eq ,sym ',val)))
954 (t `(equal ,sym ',val)))
955 (pcase--u1 matches code vars then-rest)
956 (pcase--u else-rest))))
957 ((eq (car-safe upat) 'not)
958 ;; FIXME: The implementation below is naive and results in
959 ;; inefficient code.
960 ;; To make it work right, we would need to turn pcase--u1's
961 ;; `code' and `vars' into a single argument of the same form as
962 ;; `rest'. We would also need to split this new `then-rest' argument
963 ;; for every test (currently we don't bother to do it since
964 ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
965 ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
966 ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
967 (pcase--u1 `((match ,sym . ,(cadr upat)))
968 ;; FIXME: This codegen is not careful to share its
969 ;; code if used several times: code blow up is likely.
970 (lambda (_vars)
971 ;; `vars' will likely contain bindings which are
972 ;; not always available in other paths to
973 ;; `rest', so there' no point trying to pass
974 ;; them down.
975 (pcase--u rest))
976 vars
977 (list `((and . ,matches) ,code . ,vars))))
978 (t (error "Unknown pattern `%S'" upat)))))
979 (t (error "Incorrect MATCH %S" (car matches)))))
981 (def-edebug-elem-spec 'pcase-QPAT
982 ;; Cf. edebug spec for `backquote-form' in edebug.el.
983 '(&or ("," pcase-PAT)
984 (pcase-QPAT [&rest [&not ","] pcase-QPAT]
985 . [&or nil pcase-QPAT])
986 (vector &rest pcase-QPAT)
987 sexp))
989 (pcase-defmacro \` (qpat)
990 "Backquote-style pcase patterns: \\=`QPAT
991 QPAT can take the following forms:
992 (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
993 [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match
994 its 0..(n-1)th elements, respectively.
995 ,PAT matches if the `pcase' pattern PAT matches.
996 SYMBOL matches if EXPVAL is `equal' to SYMBOL.
997 KEYWORD likewise for KEYWORD.
998 NUMBER likewise for NUMBER.
999 STRING likewise for STRING.
1001 The list or vector QPAT is a template. The predicate formed
1002 by a backquote-style pattern is a combination of those
1003 formed by any sub-patterns, wrapped in a top-level condition:
1004 EXPVAL must be \"congruent\" with the template. For example:
1006 \\=`(technical ,forum)
1008 The predicate is the logical-AND of:
1009 - Is EXPVAL a list of two elements?
1010 - Is the first element the symbol `technical'?
1011 - True! (The second element can be anything, and for the sake
1012 of the body forms, its value is bound to the symbol `forum'.)"
1013 (declare (debug (pcase-QPAT)))
1014 (cond
1015 ((eq (car-safe qpat) '\,) (cadr qpat))
1016 ((vectorp qpat)
1017 `(and (pred vectorp)
1018 (app length ,(length qpat))
1019 ,@(let ((upats nil))
1020 (dotimes (i (length qpat))
1021 (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
1022 upats))
1023 (nreverse upats))))
1024 ((consp qpat)
1025 `(and (pred consp)
1026 (app car-safe ,(list '\` (car qpat)))
1027 (app cdr-safe ,(list '\` (cdr qpat)))))
1028 ((or (stringp qpat) (numberp qpat) (symbolp qpat)) `',qpat)
1029 ;; In all other cases just raise an error so we can't break
1030 ;; backward compatibility when adding \` support for other
1031 ;; compounded values that are not `consp'
1032 (t (error "Unknown QPAT: %S" qpat))))
1034 (pcase-defmacro let (pat expr)
1035 "Matches if EXPR matches PAT."
1036 (declare (debug (pcase-PAT form)))
1037 `(app (lambda (_) ,expr) ,pat))
1039 ;; (pcase-defmacro guard (expr)
1040 ;; "Matches if EXPR is non-nil."
1041 ;; (declare (debug (form)))
1042 ;; `(pred (lambda (_) ,expr)))
1044 (provide 'pcase)
1045 ;;; pcase.el ends here