; Auto-commit of loaddefs files.
[emacs.git] / lisp / emacs-lisp / pcase.el
Commit [+]AuthorDateLineData
513749ee Stefan Monnier2012-06-08 09:18:26 -04001;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +02002
7e09ef09 Paul Eggert2015-01-01 14:26:41 -08003;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +02004
5;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
ca3afb79 Juanma Barranquero2011-02-28 05:24:40 +01006;; Keywords:
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +02007
8;; This file is part of GNU Emacs.
9
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.
14
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.
19
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/>.
22
23;;; Commentary:
24
25;; ML-style pattern matching.
26;; The entry points are autoloaded.
27
dcc029e0
SM
Stefan Monnier2010-10-28 21:05:38 -040028;; Todo:
29
ca105506
SM
Stefan Monnier2011-03-16 16:08:39 -040030;; - (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.
dcc029e0
SM
Stefan Monnier2010-10-28 21:05:38 -040034;; - 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
872ab164 Stefan Monnier2010-11-24 11:39:51 -050038;; extension provide its own `pcase--split-<foo>' thingy.
ca105506 Stefan Monnier2011-03-16 16:08:39 -040039;; - along these lines, provide patterns to match CL structs.
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -050040;; - provide something like (setq VAR) so a var can be set rather than
41;; let-bound.
a179e3f7
SM
Stefan Monnier2012-05-26 11:52:27 -040042;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
43;; this :-()
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -050044;; - try and be more clever to reduce the size of the decision tree, and
ca105506 Stefan Monnier2011-03-16 16:08:39 -040045;; to reduce the number of leaves that need to be turned into function:
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -050046;; - first, do the tests shared by all remaining branches (it will have
a179e3f7 Stefan Monnier2012-05-26 11:52:27 -040047;; to be performed anyway, so better do it first so it's shared).
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -050048;; - then choose the test that discriminates more (?).
a179e3f7 Stefan Monnier2012-05-26 11:52:27 -040049;; - provide Agda's `with' (along with its `...' companion).
dde09cdb Stefan Monnier2015-05-24 22:38:05 -040050;; - implement (not PAT). This might require a significant redesign.
dcc029e0
SM
Stefan Monnier2010-10-28 21:05:38 -040051;; - 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.
53
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +020054;;; Code:
55
4dd1c416
SM
Stefan Monnier2012-06-07 15:25:48 -040056(require 'macroexp)
57
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +020058;; 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.
972debf2
SM
Stefan Monnier2012-09-04 13:40:25 -040063;; FIXME: Now that macroexpansion is also performed when loading an interpreted
64;; file, this is not a real problem any more.
e2abe5a1 Stefan Monnier2011-03-05 23:48:17 -050065(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -040066;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
67;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +020068
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -040069(defconst pcase--dontcare-upats '(t _ pcase--dontcare))
872ab164 Stefan Monnier2010-11-24 11:39:51 -050070
85b3d352
LL
Leo Liu2014-09-14 00:30:21 +080071(defvar pcase--dontwarn-upats '(pcase--dontcare))
72
a4712e11 Johan Bockgård2012-06-10 20:46:21 -040073(def-edebug-spec
dde09cdb Stefan Monnier2015-05-24 22:38:05 -040074 pcase-PAT
a4712e11 Johan Bockgård2012-06-10 20:46:21 -040075 (&or symbolp
dde09cdb
SM
Stefan Monnier2015-05-24 22:38:05 -040076 ("or" &rest pcase-PAT)
77 ("and" &rest pcase-PAT)
a4712e11 Johan Bockgård2012-06-10 20:46:21 -040078 ("guard" form)
dde09cdb Stefan Monnier2015-05-24 22:38:05 -040079 ("let" pcase-PAT form)
66a53da5 Johan Bockgård2015-04-12 16:26:51 +020080 ("pred" pcase-FUN)
dde09cdb Stefan Monnier2015-05-24 22:38:05 -040081 ("app" pcase-FUN pcase-PAT)
2e47de36 Johan Bockgård2015-04-12 16:26:52 +020082 pcase-MACRO
66a53da5
JB
Johan Bockgård2015-04-12 16:26:51 +020083 sexp))
84
85(def-edebug-spec
86 pcase-FUN
87 (&or lambda-expr
88 ;; Punt on macros/special forms.
89 (functionp &rest form)
a4712e11
JB
Johan Bockgård2012-06-10 20:46:21 -040090 sexp))
91
2e47de36
JB
Johan Bockgård2015-04-12 16:26:52 +020092(def-edebug-spec pcase-MACRO pcase--edebug-match-macro)
93
a73af965
GM
Glenn Morris2015-05-01 13:40:31 -040094;; Only called from edebug.
95(declare-function get-edebug-spec "edebug" (symbol))
96(declare-function edebug-match "edebug" (cursor specs))
97
2e47de36
JB
Johan Bockgård2015-04-12 16:26:52 +020098(defun pcase--edebug-match-macro (cursor)
99 (let (specs)
100 (mapatoms
101 (lambda (s)
102 (let ((m (get s 'pcase-macroexpander)))
103 (when (and m (get-edebug-spec m))
104 (push (cons (symbol-name s) (get-edebug-spec m))
105 specs)))))
106 (edebug-match cursor (cons '&or specs))))
107
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200108;;;###autoload
109(defmacro pcase (exp &rest cases)
110 "Perform ML-style pattern matching on EXP.
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400111CASES is a list of elements of the form (PATTERN CODE...).
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200112
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400113Patterns can take the following forms:
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200114 _ matches anything.
115 SYMBOL matches anything and binds it to SYMBOL.
dde09cdb
SM
Stefan Monnier2015-05-24 22:38:05 -0400116 (or PAT...) matches if any of the patterns matches.
117 (and PAT...) matches if all the patterns match.
875a5d0e
PE
Paul Eggert2015-08-24 23:39:33 -0700118 \\='VAL matches if the object is `equal' to VAL
119 ATOM is a shorthand for \\='ATOM.
3ef31167 Stefan Monnier2015-06-16 12:37:33 -0400120 ATOM can be a keyword, an integer, or a string.
2b968ea6 Stefan Monnier2014-09-22 14:05:22 -0400121 (pred FUN) matches if FUN applied to the object returns non-nil.
dcc029e0 Stefan Monnier2010-10-28 21:05:38 -0400122 (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
dde09cdb
SM
Stefan Monnier2015-05-24 22:38:05 -0400123 (let PAT EXP) matches if EXP matches PAT.
124 (app FUN PAT) matches if FUN applied to the object matches PAT.
f9d554dd
SM
Stefan Monnier2011-02-17 23:58:21 -0500125If a SYMBOL is used twice in the same pattern (i.e. the pattern is
126\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200127
2b968ea6
SM
Stefan Monnier2014-09-22 14:05:22 -0400128FUN can take the form
129 SYMBOL or (lambda ARGS BODY) in which case it's called with one argument.
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400130 (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
7abaf5cc Stefan Monnier2012-07-25 21:27:33 -0400131 which is the value being matched.
2b968ea6
SM
Stefan Monnier2014-09-22 14:05:22 -0400132So a FUN of the form SYMBOL is equivalent to one of the form (FUN).
133FUN can refer to variables bound earlier in the pattern.
134FUN is assumed to be pure, i.e. it can be dropped if its result is not used,
135and two identical calls can be merged into one.
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200136E.g. you can match pairs where the cdr is larger than the car with a pattern
4643f6c2
PE
Paul Eggert2015-05-28 00:44:32 -0700137like \\=`(,a . ,(pred (< a))) or, with more checks:
138\\=`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400139
140Additional patterns can be defined via `pcase-defmacro'.
141Currently, the following patterns are provided this way:"
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400142 (declare (indent 1) (debug (form &rest (pcase-PAT body))))
e2abe5a1
SM
Stefan Monnier2011-03-05 23:48:17 -0500143 ;; We want to use a weak hash table as a cache, but the key will unavoidably
144 ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
145 ;; we're called so it'll be immediately GC'd. So we use (car cases) as key
146 ;; which does come straight from the source code and should hence not be GC'd
147 ;; so easily.
148 (let ((data (gethash (car cases) pcase--memoize)))
149 ;; data = (EXP CASES . EXPANSION)
150 (if (and (equal exp (car data)) (equal cases (cadr data)))
151 ;; We have the right expansion.
152 (cddr data)
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400153 ;; (when (gethash (car cases) pcase--memoize-1)
154 ;; (message "pcase-memoize failed because of weak key!!"))
155 ;; (when (gethash (car cases) pcase--memoize-2)
156 ;; (message "pcase-memoize failed because of eq test on %S"
157 ;; (car cases)))
e2abe5a1
SM
Stefan Monnier2011-03-05 23:48:17 -0500158 (when data
159 (message "pcase-memoize: equal first branch, yet different"))
160 (let ((expansion (pcase--expand exp cases)))
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400161 (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
162 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
163 ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
e2abe5a1 Stefan Monnier2011-03-05 23:48:17 -0500164 expansion))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200165
a73af965 Glenn Morris2015-05-01 13:40:31 -0400166(declare-function help-fns--signature "help-fns"
b2205626 Paul Eggert2015-06-11 10:23:46 -0700167 (function doc real-def real-function raw))
a73af965 Glenn Morris2015-05-01 13:40:31 -0400168
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400169;; FIXME: Obviously, this will collide with nadvice's use of
170;; function-documentation if we happen to advise `pcase'.
171(put 'pcase 'function-documentation '(pcase--make-docstring))
172(defun pcase--make-docstring ()
173 (let* ((main (documentation (symbol-function 'pcase) 'raw))
174 (ud (help-split-fundoc main 'pcase)))
d6b91bf5
GM
Glenn Morris2015-05-01 13:39:23 -0400175 ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works,
176 ;; where cl-lib is anything using pcase-defmacro.
177 (require 'help-fns)
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400178 (with-temp-buffer
179 (insert (or (cdr ud) main))
180 (mapatoms
181 (lambda (symbol)
182 (let ((me (get symbol 'pcase-macroexpander)))
183 (when me
184 (insert "\n\n-- ")
185 (let* ((doc (documentation me 'raw)))
186 (setq doc (help-fns--signature symbol doc me
b2205626 Paul Eggert2015-06-11 10:23:46 -0700187 (indirect-function me) t))
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400188 (insert "\n" (or doc "Not documented.")))))))
189 (let ((combined-doc (buffer-string)))
190 (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
191
85b3d352
LL
Leo Liu2014-09-14 00:30:21 +0800192;;;###autoload
193(defmacro pcase-exhaustive (exp &rest cases)
194 "The exhaustive version of `pcase' (which see)."
195 (declare (indent 1) (debug pcase))
196 (let* ((x (make-symbol "x"))
197 (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
198 (pcase--expand
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400199 ;; FIXME: Could we add the FILE:LINE data in the error message?
c87523bd Paul Eggert2015-08-21 20:19:46 -0700200 exp (append cases `((,x (error "No clause matching ‘%S’" ,x)))))))
85b3d352 Leo Liu2014-09-14 00:30:21 +0800201
751adc4b
LL
Leo Liu2015-02-09 10:05:44 +0800202;;;###autoload
203(defmacro pcase-lambda (lambda-list &rest body)
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400204 "Like `lambda' but allow each argument to be a pattern.
8aa13d07
SM
Stefan Monnier2015-03-19 13:46:36 -0400205I.e. accepts the usual &optional and &rest keywords, but every
206formal argument can be any pattern accepted by `pcase' (a mere
207variable name being but a special case of it)."
751adc4b Leo Liu2015-02-09 10:05:44 +0800208 (declare (doc-string 2) (indent defun)
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400209 (debug ((&rest pcase-PAT) body)))
8aa13d07
SM
Stefan Monnier2015-03-19 13:46:36 -0400210 (let* ((bindings ())
211 (parsed-body (macroexp-parse-body body))
212 (args (mapcar (lambda (pat)
213 (if (symbolp pat)
214 ;; Simple vars and &rest/&optional are just passed
215 ;; through unchanged.
216 pat
217 (let ((arg (make-symbol
218 (format "arg%s" (length bindings)))))
219 (push `(,pat ,arg) bindings)
220 arg)))
221 lambda-list)))
222 `(lambda ,args ,@(car parsed-body)
223 (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body)))))
751adc4b Leo Liu2015-02-09 10:05:44 +0800224
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400225(defun pcase--let* (bindings body)
226 (cond
227 ((null bindings) (macroexp-progn body))
228 ((pcase--trivial-upat-p (caar bindings))
229 (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
230 (t
231 (let ((binding (pop bindings)))
232 (pcase--expand
233 (cadr binding)
234 `((,(car binding) ,(pcase--let* bindings body))
a464a6c7
SM
Stefan Monnier2012-07-11 19:13:41 -0400235 ;; We can either signal an error here, or just use `pcase--dontcare'
236 ;; which generates more efficient code. In practice, if we use
237 ;; `pcase--dontcare' we will still often get an error and the few
238 ;; cases where we don't do not matter that much, so
239 ;; it's a better choice.
240 (pcase--dontcare nil)))))))
82ad98e3 Stefan Monnier2012-06-10 20:33:33 -0400241
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200242;;;###autoload
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500243(defmacro pcase-let* (bindings &rest body)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200244 "Like `let*' but where you can use `pcase' patterns for bindings.
245BODY should be an expression, and BINDINGS should be a list of bindings
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400246of the form (PAT EXP)."
c41045e6 Stefan Monnier2012-05-15 14:45:27 -0400247 (declare (indent 1)
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400248 (debug ((&rest (pcase-PAT &optional form)) body)))
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400249 (let ((cached (gethash bindings pcase--memoize)))
250 ;; cached = (BODY . EXPANSION)
251 (if (equal (car cached) body)
252 (cdr cached)
253 (let ((expansion (pcase--let* bindings body)))
254 (puthash bindings (cons body expansion) pcase--memoize)
255 expansion))))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200256
257;;;###autoload
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500258(defmacro pcase-let (bindings &rest body)
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200259 "Like `let' but where you can use `pcase' patterns for bindings.
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500260BODY should be a list of expressions, and BINDINGS should be a list of bindings
dde09cdb
SM
Stefan Monnier2015-05-24 22:38:05 -0400261of the form (PAT EXP).
262The macro is expanded and optimized under the assumption that those
263patterns *will* match, so a mismatch may go undetected or may cause
264any kind of error."
c41045e6 Stefan Monnier2012-05-15 14:45:27 -0400265 (declare (indent 1) (debug pcase-let*))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200266 (if (null (cdr bindings))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500267 `(pcase-let* ,bindings ,@body)
268 (let ((matches '()))
269 (dolist (binding (prog1 bindings (setq bindings nil)))
270 (cond
271 ((memq (car binding) pcase--dontcare-upats)
272 (push (cons (make-symbol "_") (cdr binding)) bindings))
273 ((pcase--trivial-upat-p (car binding)) (push binding bindings))
274 (t
275 (let ((tmpvar (make-symbol (format "x%d" (length bindings)))))
276 (push (cons tmpvar (cdr binding)) bindings)
277 (push (list (car binding) tmpvar) matches)))))
278 `(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
279
4aca2fdf Stefan Monnier2015-04-13 14:46:58 -0400280;;;###autoload
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500281(defmacro pcase-dolist (spec &rest body)
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400282 (declare (indent 1) (debug ((pcase-PAT form) body)))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500283 (if (pcase--trivial-upat-p (car spec))
284 `(dolist ,spec ,@body)
285 (let ((tmpvar (make-symbol "x")))
286 `(dolist (,tmpvar ,@(cdr spec))
287 (pcase-let* ((,(car spec) ,tmpvar))
288 ,@body)))))
289
290
291(defun pcase--trivial-upat-p (upat)
292 (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))
293
294(defun pcase--expand (exp cases)
e2abe5a1
SM
Stefan Monnier2011-03-05 23:48:17 -0500295 ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
296 ;; (emacs-pid) exp (sxhash cases))
2ee3d7f0 Stefan Monnier2012-06-22 09:42:38 -0400297 (macroexp-let2 macroexp-copyable-p val exp
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400298 (let* ((defs ())
299 (seen '())
300 (codegen
301 (lambda (code vars)
302 (let ((prev (assq code seen)))
303 (if (not prev)
304 (let ((res (pcase-codegen code vars)))
305 (push (list code vars res) seen)
306 res)
307 ;; Since we use a tree-based pattern matching
308 ;; technique, the leaves (the places that contain the
309 ;; code to run once a pattern is matched) can get
310 ;; copied a very large number of times, so to avoid
311 ;; code explosion, we need to keep track of how many
312 ;; times we've used each leaf and move it
313 ;; to a separate function if that number is too high.
314 ;;
315 ;; We've already used this branch. So it is shared.
316 (let* ((code (car prev)) (cdrprev (cdr prev))
317 (prevvars (car cdrprev)) (cddrprev (cdr cdrprev))
318 (res (car cddrprev)))
319 (unless (symbolp res)
320 ;; This is the first repeat, so we have to move
321 ;; the branch to a separate function.
322 (let ((bsym
323 (make-symbol (format "pcase-%d" (length defs)))))
ee4b1330
SM
Stefan Monnier2012-06-18 15:23:35 -0400324 (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code))
325 defs)
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400326 (setcar res 'funcall)
327 (setcdr res (cons bsym (mapcar #'cdr prevvars)))
328 (setcar (cddr prev) bsym)
329 (setq res bsym)))
330 (setq vars (copy-sequence vars))
331 (let ((args (mapcar (lambda (pa)
332 (let ((v (assq (car pa) vars)))
333 (setq vars (delq v vars))
334 (cdr v)))
335 prevvars)))
336 ;; If some of `vars' were not found in `prevvars', that's
337 ;; OK it just means those vars aren't present in all
338 ;; branches, so they can be used within the pattern
339 ;; (e.g. by a `guard/let/pred') but not in the branch.
340 ;; FIXME: But if some of `prevvars' are not in `vars' we
341 ;; should remove them from `prevvars'!
342 `(funcall ,res ,@args)))))))
ee4b1330 Stefan Monnier2012-06-18 15:23:35 -0400343 (used-cases ())
82ad98e3
SM
Stefan Monnier2012-06-10 20:33:33 -0400344 (main
345 (pcase--u
346 (mapcar (lambda (case)
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400347 `(,(pcase--match val (pcase--macroexpand (car case)))
ee4b1330
SM
Stefan Monnier2012-06-18 15:23:35 -0400348 ,(lambda (vars)
349 (unless (memq case used-cases)
350 ;; Keep track of the cases that are used.
351 (push case used-cases))
352 (funcall
353 (if (pcase--small-branch-p (cdr case))
354 ;; Don't bother sharing multiple
355 ;; occurrences of this leaf since it's small.
356 #'pcase-codegen codegen)
357 (cdr case)
358 vars))))
82ad98e3 Stefan Monnier2012-06-10 20:33:33 -0400359 cases))))
ee4b1330 Stefan Monnier2012-06-18 15:23:35 -0400360 (dolist (case cases)
85b3d352
LL
Leo Liu2014-09-14 00:30:21 +0800361 (unless (or (memq case used-cases)
362 (memq (car case) pcase--dontwarn-upats))
ee4b1330 Stefan Monnier2012-06-18 15:23:35 -0400363 (message "Redundant pcase pattern: %S" (car case))))
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400364 (macroexp-let* defs main))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200365
536cda1f
SM
Stefan Monnier2014-09-22 11:04:12 -0400366(defun pcase--macroexpand (pat)
367 "Expands all macro-patterns in PAT."
368 (let ((head (car-safe pat)))
369 (cond
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400370 ((null head)
371 (if (pcase--self-quoting-p pat) `',pat pat))
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400372 ((memq head '(pred guard quote)) pat)
536cda1f
SM
Stefan Monnier2014-09-22 11:04:12 -0400373 ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
374 ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
375 ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
376 (t
377 (let* ((expander (get head 'pcase-macroexpander))
378 (npat (if expander (apply expander (cdr pat)))))
379 (if (null npat)
380 (error (if expander
381 "Unexpandable %s pattern: %S"
382 "Unknown %s pattern: %S")
383 head pat)
384 (pcase--macroexpand npat)))))))
385
386;;;###autoload
387(defmacro pcase-defmacro (name args &rest body)
dde09cdb
SM
Stefan Monnier2015-05-24 22:38:05 -0400388 "Define a new kind of pcase PATTERN, by macro expansion.
389Patterns of the form (NAME ...) will be expanded according
390to this macro."
ae277259 Stefan Monnier2015-03-23 18:24:30 -0400391 (declare (indent 2) (debug defun) (doc-string 3))
2e47de36
JB
Johan Bockgård2015-04-12 16:26:52 +0200392 ;; Add the function via `fsym', so that an autoload cookie placed
393 ;; on a pcase-defmacro will cause the macro to be loaded on demand.
394 (let ((fsym (intern (format "%s--pcase-macroexpander" name)))
395 (decl (assq 'declare body)))
396 (when decl (setq body (remove decl body)))
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400397 `(progn
398 (defun ,fsym ,args ,@body)
2e47de36 Johan Bockgård2015-04-12 16:26:52 +0200399 (put ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
ae277259 Stefan Monnier2015-03-23 18:24:30 -0400400 (put ',name 'pcase-macroexpander #',fsym))))
536cda1f Stefan Monnier2014-09-22 11:04:12 -0400401
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400402(defun pcase--match (val upat)
403 "Build a MATCH structure, hoisting all `or's and `and's outside."
404 (cond
405 ;; Hoist or/and patterns into or/and matches.
406 ((memq (car-safe upat) '(or and))
407 `(,(car upat)
408 ,@(mapcar (lambda (upat)
409 (pcase--match val upat))
410 (cdr upat))))
411 (t
412 `(match ,val . ,upat))))
413
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200414(defun pcase-codegen (code vars)
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400415 ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
6876a58d
SM
Stefan Monnier2012-05-29 10:28:02 -0400416 ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
417 ;; codegen from later metamorphosing this let into a funcall.
418 `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200419 ,@code))
420
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500421(defun pcase--small-branch-p (code)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200422 (and (= 1 (length code))
423 (or (not (consp (car code)))
424 (let ((small t))
425 (dolist (e (car code))
426 (if (consp e) (setq small nil)))
427 small))))
428
429;; Try to use `cond' rather than a sequence of `if's, so as to reduce
430;; the depth of the generated tree.
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500431(defun pcase--if (test then else)
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200432 (cond
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500433 ((eq else :pcase--dontcare) then)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500434 ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400435 (t (macroexp-if test then else))))
5342bb06 Stefan Monnier2012-05-04 22:05:49 -0400436
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200437;; Note about MATCH:
438;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
439;; check, we want to turn all the similar patterns into ones of the form
440;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
441;; Earlier code hence used branches of the form (MATCHES . CODE) where
442;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
443;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
444;; no easy way to eliminate the `consp' check in such a representation.
445;; So we replaced the MATCHES by the MATCH below which can be made up
446;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
447;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
448;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
449;; The downside is that we now have `or' and `and' both in MATCH and
450;; in PAT, so there are different equivalent representations and we
451;; need to handle them all. We do not try to systematically
452;; canonicalize them to one form over another, but we do occasionally
453;; turn one into the other.
454
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500455(defun pcase--u (branches)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200456 "Expand matcher for rules BRANCHES.
457Each BRANCH has the form (MATCH CODE . VARS) where
458CODE is the code generator for that branch.
459VARS is the set of vars already bound by earlier matches.
460MATCH is the pattern that needs to be matched, of the form:
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400461 (match VAR . PAT)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200462 (and MATCH ...)
463 (or MATCH ...)"
464 (when (setq branches (delq nil branches))
9a05edc4
SM
Stefan Monnier2011-02-18 08:55:51 -0500465 (let* ((carbranch (car branches))
466 (match (car carbranch)) (cdarbranch (cdr carbranch))
467 (code (car cdarbranch))
468 (vars (cdr cdarbranch)))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500469 (pcase--u1 (list match) code vars (cdr branches)))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200470
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500471(defun pcase--and (match matches)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200472 (if matches `(and ,match ,@matches) match))
473
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500474(defconst pcase-mutually-exclusive-predicates
475 '((symbolp . integerp)
476 (symbolp . numberp)
477 (symbolp . consp)
478 (symbolp . arrayp)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400479 (symbolp . vectorp)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500480 (symbolp . stringp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400481 (symbolp . byte-code-function-p)
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500482 (integerp . consp)
483 (integerp . arrayp)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400484 (integerp . vectorp)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500485 (integerp . stringp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400486 (integerp . byte-code-function-p)
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500487 (numberp . consp)
488 (numberp . arrayp)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400489 (numberp . vectorp)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500490 (numberp . stringp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400491 (numberp . byte-code-function-p)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500492 (consp . arrayp)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400493 (consp . vectorp)
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500494 (consp . stringp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400495 (consp . byte-code-function-p)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400496 (arrayp . byte-code-function-p)
671d5c16
SM
Stefan Monnier2013-08-04 16:18:11 -0400497 (vectorp . byte-code-function-p)
498 (stringp . vectorp)
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400499 (stringp . byte-code-function-p)))
1f0816b6 Stefan Monnier2011-02-26 21:50:38 -0500500
671d5c16
SM
Stefan Monnier2013-08-04 16:18:11 -0400501(defun pcase--mutually-exclusive-p (pred1 pred2)
502 (or (member (cons pred1 pred2)
503 pcase-mutually-exclusive-predicates)
504 (member (cons pred2 pred1)
505 pcase-mutually-exclusive-predicates)))
506
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500507(defun pcase--split-match (sym splitter match)
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500508 (cond
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400509 ((eq (car-safe match) 'match)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200510 (if (not (eq sym (cadr match)))
511 (cons match match)
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400512 (let ((res (funcall splitter (cddr match))))
513 (cons (or (car res) match) (or (cdr res) match)))))
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400514 ((memq (car-safe match) '(or and))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200515 (let ((then-alts '())
516 (else-alts '())
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500517 (neutral-elem (if (eq 'or (car match))
518 :pcase--fail :pcase--succeed))
519 (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail)))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200520 (dolist (alt (cdr match))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500521 (let ((split (pcase--split-match sym splitter alt)))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200522 (unless (eq (car split) neutral-elem)
523 (push (car split) then-alts))
524 (unless (eq (cdr split) neutral-elem)
525 (push (cdr split) else-alts))))
526 (cons (cond ((memq zero-elem then-alts) zero-elem)
527 ((null then-alts) neutral-elem)
528 ((null (cdr then-alts)) (car then-alts))
529 (t (cons (car match) (nreverse then-alts))))
530 (cond ((memq zero-elem else-alts) zero-elem)
531 ((null else-alts) neutral-elem)
532 ((null (cdr else-alts)) (car else-alts))
533 (t (cons (car match) (nreverse else-alts)))))))
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400534 ((memq match '(:pcase--succeed :pcase--fail)) (cons match match))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200535 (t (error "Uknown MATCH %s" match))))
536
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500537(defun pcase--split-rest (sym splitter rest)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200538 (let ((then-rest '())
539 (else-rest '()))
540 (dolist (branch rest)
541 (let* ((match (car branch))
542 (code&vars (cdr branch))
bbd240ce Paul Eggert2011-12-14 23:24:10 -0800543 (split
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500544 (pcase--split-match sym splitter match)))
bbd240ce
PE
Paul Eggert2011-12-14 23:24:10 -0800545 (unless (eq (car split) :pcase--fail)
546 (push (cons (car split) code&vars) then-rest))
547 (unless (eq (cdr split) :pcase--fail)
548 (push (cons (cdr split) code&vars) else-rest))))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200549 (cons (nreverse then-rest) (nreverse else-rest))))
550
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500551(defun pcase--split-equal (elem pat)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200552 (cond
553 ;; The same match will give the same result.
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400554 ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem))
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500555 '(:pcase--succeed . :pcase--fail))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200556 ;; A different match will fail if this one succeeds.
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400557 ((and (eq (car-safe pat) 'quote)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200558 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
559 ;; (consp (cadr pat)))
560 )
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500561 '(:pcase--fail . nil))
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500562 ((and (eq (car-safe pat) 'pred)
563 (symbolp (cadr pat))
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500564 (get (cadr pat) 'side-effect-free))
6f547583
SM
Stefan Monnier2014-01-02 23:40:30 -0500565 (ignore-errors
566 (if (funcall (cadr pat) elem)
567 '(:pcase--succeed . nil)
568 '(:pcase--fail . nil))))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200569
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500570(defun pcase--split-member (elems pat)
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400571 ;; FIXME: The new pred-based member code doesn't do these optimizations!
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500572 ;; Based on pcase--split-equal.
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200573 (cond
dcc029e0
SM
Stefan Monnier2010-10-28 21:05:38 -0400574 ;; The same match (or a match of membership in a superset) will
575 ;; give the same result, but we don't know how to check it.
4de81ee0 Stefan Monnier2010-09-01 12:03:08 +0200576 ;; (???
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500577 ;; '(:pcase--succeed . nil))
4de81ee0 Stefan Monnier2010-09-01 12:03:08 +0200578 ;; A match for one of the elements may succeed or fail.
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400579 ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems))
4de81ee0 Stefan Monnier2010-09-01 12:03:08 +0200580 nil)
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200581 ;; A different match will fail if this one succeeds.
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400582 ((and (eq (car-safe pat) 'quote)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200583 ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
584 ;; (consp (cadr pat)))
585 )
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500586 '(:pcase--fail . nil))
1f0816b6
SM
Stefan Monnier2011-02-26 21:50:38 -0500587 ((and (eq (car-safe pat) 'pred)
588 (symbolp (cadr pat))
589 (get (cadr pat) 'side-effect-free)
6f547583
SM
Stefan Monnier2014-01-02 23:40:30 -0500590 (ignore-errors
591 (let ((p (cadr pat)) (all t))
592 (dolist (elem elems)
593 (unless (funcall p elem) (setq all nil)))
594 all)))
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500595 '(:pcase--succeed . nil))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200596
0b64b838 Stefan Monnier2013-07-08 17:54:54 -0400597(defun pcase--split-pred (vars upat pat)
5342bb06
SM
Stefan Monnier2012-05-04 22:05:49 -0400598 (let (test)
599 (cond
0b64b838
SM
Stefan Monnier2013-07-08 17:54:54 -0400600 ((and (equal upat pat)
601 ;; For predicates like (pred (> a)), two such predicates may
602 ;; actually refer to different variables `a'.
603 (or (and (eq 'pred (car upat)) (symbolp (cadr upat)))
604 ;; FIXME: `vars' gives us the environment in which `upat' will
605 ;; run, but we don't have the environment in which `pat' will
606 ;; run, so we can't do a reliable verification. But let's try
607 ;; and catch at least the easy cases such as (bug#14773).
608 (not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
609 '(:pcase--succeed . :pcase--fail))
5342bb06 Stefan Monnier2012-05-04 22:05:49 -0400610 ((and (eq 'pred (car upat))
671d5c16
SM
Stefan Monnier2013-08-04 16:18:11 -0400611 (let ((otherpred
612 (cond ((eq 'pred (car-safe pat)) (cadr pat))
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400613 ((not (eq 'quote (car-safe pat))) nil)
671d5c16 Stefan Monnier2013-08-04 16:18:11 -0400614 ((consp (cadr pat)) #'consp)
d7d72624 Stefan Monnier2015-03-23 23:40:06 -0400615 ((stringp (cadr pat)) #'stringp)
671d5c16
SM
Stefan Monnier2013-08-04 16:18:11 -0400616 ((vectorp (cadr pat)) #'vectorp)
617 ((byte-code-function-p (cadr pat))
618 #'byte-code-function-p))))
619 (pcase--mutually-exclusive-p (cadr upat) otherpred)))
4bdc3526 Stefan Monnier2013-01-08 17:26:21 -0500620 '(:pcase--fail . nil))
5342bb06 Stefan Monnier2012-05-04 22:05:49 -0400621 ((and (eq 'pred (car upat))
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400622 (eq 'quote (car-safe pat))
5342bb06
SM
Stefan Monnier2012-05-04 22:05:49 -0400623 (symbolp (cadr upat))
624 (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
625 (get (cadr upat) 'side-effect-free)
626 (ignore-errors
627 (setq test (list (funcall (cadr upat) (cadr pat))))))
628 (if (car test)
4bdc3526
SM
Stefan Monnier2013-01-08 17:26:21 -0500629 '(nil . :pcase--fail)
630 '(:pcase--fail . nil))))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200631
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500632(defun pcase--fgrep (vars sexp)
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200633 "Check which of the symbols VARS appear in SEXP."
634 (let ((res '()))
635 (while (consp sexp)
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500636 (dolist (var (pcase--fgrep vars (pop sexp)))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200637 (unless (memq var res) (push var res))))
638 (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
639 res))
640
19faa8e8 Stefan Monnier2012-07-10 05:26:04 -0400641(defun pcase--self-quoting-p (upat)
3ef31167 Stefan Monnier2015-06-16 12:37:33 -0400642 (or (keywordp upat) (integerp upat) (stringp upat)))
19faa8e8 Stefan Monnier2012-07-10 05:26:04 -0400643
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400644(defun pcase--app-subst-match (match sym fun nsym)
645 (cond
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400646 ((eq (car-safe match) 'match)
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400647 (if (and (eq sym (cadr match))
648 (eq 'app (car-safe (cddr match)))
649 (equal fun (nth 1 (cddr match))))
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400650 (pcase--match nsym (nth 2 (cddr match)))
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400651 match))
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400652 ((memq (car-safe match) '(or and))
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400653 `(,(car match)
654 ,@(mapcar (lambda (match)
655 (pcase--app-subst-match match sym fun nsym))
656 (cdr match))))
528872c5 Stefan Monnier2014-09-27 00:24:06 -0400657 ((memq match '(:pcase--succeed :pcase--fail)) match)
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400658 (t (error "Uknown MATCH %s" match))))
659
660(defun pcase--app-subst-rest (rest sym fun nsym)
661 (mapcar (lambda (branch)
662 `(,(pcase--app-subst-match (car branch) sym fun nsym)
663 ,@(cdr branch)))
664 rest))
665
7f457c06
SM
Stefan Monnier2012-09-28 08:18:38 -0400666(defsubst pcase--mark-used (sym)
667 ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
668 (if (symbolp sym) (put sym 'pcase-used t)))
669
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400670(defmacro pcase--flip (fun arg1 arg2)
671 "Helper function, used internally to avoid (funcall (lambda ...) ...)."
672 (declare (debug (sexp body)))
673 `(,fun ,arg2 ,arg1))
674
2b968ea6
SM
Stefan Monnier2014-09-22 14:05:22 -0400675(defun pcase--funcall (fun arg vars)
676 "Build a function call to FUN with arg ARG."
677 (if (symbolp fun)
678 `(,fun ,arg)
679 (let* (;; `vs' is an upper bound on the vars we need.
680 (vs (pcase--fgrep (mapcar #'car vars) fun))
681 (env (mapcar (lambda (var)
682 (list var (cdr (assq var vars))))
683 vs))
684 (call (progn
685 (when (memq arg vs)
686 ;; `arg' is shadowed by `env'.
687 (let ((newsym (make-symbol "x")))
688 (push (list newsym arg) env)
689 (setq arg newsym)))
690 (if (functionp fun)
691 `(funcall #',fun ,arg)
692 `(,@fun ,arg)))))
693 (if (null vs)
694 call
695 ;; Let's not replace `vars' in `fun' since it's
696 ;; too difficult to do it right, instead just
697 ;; let-bind `vars' around `fun'.
698 `(let* ,env ,call)))))
699
700(defun pcase--eval (exp vars)
701 "Build an expression that will evaluate EXP."
702 (let* ((found (assq exp vars)))
703 (if found (cdr found)
704 (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
705 (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
706 vs)))
707 (if env (macroexp-let* env exp) exp)))))
708
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200709;; It's very tempting to use `pcase' below, tho obviously, it'd create
710;; bootstrapping problems.
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500711(defun pcase--u1 (matches code vars rest)
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200712 "Return code that runs CODE (with VARS) if MATCHES match.
ca3afb79 Juanma Barranquero2011-02-28 05:24:40 +0100713Otherwise, it defers to REST which is a list of branches of the form
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200714\(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
715 ;; Depending on the order in which we choose to check each of the MATCHES,
716 ;; the resulting tree may be smaller or bigger. So in general, we'd want
717 ;; to be careful to chose the "optimal" order. But predicate
718 ;; patterns make this harder because they create dependencies
719 ;; between matches. So we don't bother trying to reorder anything.
720 (cond
721 ((null matches) (funcall code vars))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500722 ((eq :pcase--fail (car matches)) (pcase--u rest))
723 ((eq :pcase--succeed (car matches))
724 (pcase--u1 (cdr matches) code vars rest))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200725 ((eq 'and (caar matches))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500726 (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200727 ((eq 'or (caar matches))
728 (let* ((alts (cdar matches))
729 (var (if (eq (caar alts) 'match) (cadr (car alts))))
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400730 (simples '()) (others '()) (memq-ok t))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200731 (when var
732 (dolist (alt alts)
733 (if (and (eq (car alt) 'match) (eq var (cadr alt))
734 (let ((upat (cddr alt)))
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400735 (eq (car-safe upat) 'quote)))
736 (let ((val (cadr (cddr alt))))
737 (unless (or (integerp val) (symbolp val))
738 (setq memq-ok nil))
739 (push (cadr (cddr alt)) simples))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200740 (push alt others))))
741 (cond
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500742 ((null alts) (error "Please avoid it") (pcase--u rest))
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400743 ;; Yes, we can use `memq' (or `member')!
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200744 ((> (length simples) 1)
1a625553
SM
Stefan Monnier2014-09-22 12:22:50 -0400745 (pcase--u1 (cons `(match ,var
746 . (pred (pcase--flip
747 ,(if memq-ok #'memq #'member)
748 ',simples)))
749 (cdr matches))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500750 code vars
751 (if (null others) rest
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500752 (cons (cons
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500753 (pcase--and (if (cdr others)
754 (cons 'or (nreverse others))
755 (car others))
756 (cdr matches))
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500757 (cons code vars))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500758 rest))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200759 (t
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500760 (pcase--u1 (cons (pop alts) (cdr matches)) code vars
761 (if (null alts) (progn (error "Please avoid it") rest)
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500762 (cons (cons
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500763 (pcase--and (if (cdr alts)
764 (cons 'or alts) (car alts))
765 (cdr matches))
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500766 (cons code vars))
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500767 rest)))))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200768 ((eq 'match (caar matches))
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500769 (let* ((popmatches (pop matches))
d032d5e7 Stefan Monnier2011-03-01 00:03:24 -0500770 (_op (car popmatches)) (cdrpopmatches (cdr popmatches))
9a05edc4
SM
Stefan Monnier2011-02-18 08:55:51 -0500771 (sym (car cdrpopmatches))
772 (upat (cdr cdrpopmatches)))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200773 (cond
3ef31167
SM
Stefan Monnier2015-06-16 12:37:33 -0400774 ((memq upat '(t _))
775 (let ((code (pcase--u1 matches code vars rest)))
776 (if (eq upat '_) code
d3b779fa Glenn Morris2015-06-16 20:44:57 -0400777 (macroexp--warn-and-return
c87523bd Paul Eggert2015-08-21 20:19:46 -0700778 "Pattern t is deprecated. Use ‘_’ instead"
d3b779fa Glenn Morris2015-06-16 20:44:57 -0400779 code))))
a464a6c7 Stefan Monnier2012-07-11 19:13:41 -0400780 ((eq upat 'pcase--dontcare) :pcase--dontcare)
dcc029e0 Stefan Monnier2010-10-28 21:05:38 -0400781 ((memq (car-safe upat) '(guard pred))
7f457c06 Stefan Monnier2012-09-28 08:18:38 -0400782 (if (eq (car upat) 'pred) (pcase--mark-used sym))
9a05edc4 Stefan Monnier2011-02-18 08:55:51 -0500783 (let* ((splitrest
ca105506 Stefan Monnier2011-03-16 16:08:39 -0400784 (pcase--split-rest
0b64b838 Stefan Monnier2013-07-08 17:54:54 -0400785 sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
9a05edc4
SM
Stefan Monnier2011-02-18 08:55:51 -0500786 (then-rest (car splitrest))
787 (else-rest (cdr splitrest)))
2b968ea6
SM
Stefan Monnier2014-09-22 14:05:22 -0400788 (pcase--if (if (eq (car upat) 'pred)
789 (pcase--funcall (cadr upat) sym vars)
790 (pcase--eval (cadr upat) vars))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500791 (pcase--u1 matches code vars then-rest)
792 (pcase--u else-rest))))
3ef31167 Stefan Monnier2015-06-16 12:37:33 -0400793 ((and (symbolp upat) upat)
7f457c06 Stefan Monnier2012-09-28 08:18:38 -0400794 (pcase--mark-used sym)
f9d554dd
SM
Stefan Monnier2011-02-17 23:58:21 -0500795 (if (not (assq upat vars))
796 (pcase--u1 matches code (cons (cons upat sym) vars) rest)
797 ;; Non-linear pattern. Turn it into an `eq' test.
798 (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars)))))
799 matches)
800 code vars rest)))
ca105506
SM
Stefan Monnier2011-03-16 16:08:39 -0400801 ((eq (car-safe upat) 'let)
802 ;; A upat of the form (let VAR EXP).
803 ;; (pcase--u1 matches code
804 ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
2ee3d7f0 Stefan Monnier2012-06-22 09:42:38 -0400805 (macroexp-let2
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400806 macroexp-copyable-p sym
2b968ea6 Stefan Monnier2014-09-22 14:05:22 -0400807 (pcase--eval (nth 2 upat) vars)
1a625553 Stefan Monnier2014-09-22 12:22:50 -0400808 (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
4dd1c416 Stefan Monnier2012-06-07 15:25:48 -0400809 code vars rest)))
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400810 ((eq (car-safe upat) 'app)
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400811 ;; A upat of the form (app FUN PAT)
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400812 (pcase--mark-used sym)
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400813 (let* ((fun (nth 1 upat))
814 (nsym (make-symbol "x"))
815 (body
816 ;; We don't change `matches' to reuse the newly computed value,
817 ;; because we assume there shouldn't be such redundancy in there.
818 (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches)
819 code vars
820 (pcase--app-subst-rest rest sym fun nsym))))
821 (if (not (get nsym 'pcase-used))
822 body
823 (macroexp-let*
2b968ea6 Stefan Monnier2014-09-22 14:05:22 -0400824 `((,nsym ,(pcase--funcall fun sym vars)))
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400825 body))))
13b1840d Stefan Monnier2014-09-22 10:30:47 -0400826 ((eq (car-safe upat) 'quote)
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400827 (pcase--mark-used sym)
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400828 (let* ((val (cadr upat))
829 (splitrest (pcase--split-rest
830 sym (lambda (pat) (pcase--split-equal val pat)) rest))
831 (then-rest (car splitrest))
832 (else-rest (cdr splitrest)))
833 (pcase--if (cond
834 ((null val) `(null ,sym))
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400835 ((or (integerp val) (symbolp val))
836 (if (pcase--self-quoting-p val)
837 `(eq ,sym ,val)
838 `(eq ,sym ',val)))
13b1840d
SM
Stefan Monnier2014-09-22 10:30:47 -0400839 (t `(equal ,sym ',val)))
840 (pcase--u1 matches code vars then-rest)
841 (pcase--u else-rest))))
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200842 ((eq (car-safe upat) 'not)
843 ;; FIXME: The implementation below is naive and results in
844 ;; inefficient code.
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500845 ;; To make it work right, we would need to turn pcase--u1's
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200846 ;; `code' and `vars' into a single argument of the same form as
847 ;; `rest'. We would also need to split this new `then-rest' argument
848 ;; for every test (currently we don't bother to do it since
849 ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
850 ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
851 ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
872ab164 Stefan Monnier2010-11-24 11:39:51 -0500852 (pcase--u1 `((match ,sym . ,(cadr upat)))
94d11cb5
IK
Igor Kuzmin2011-02-10 13:53:49 -0500853 ;; FIXME: This codegen is not careful to share its
854 ;; code if used several times: code blow up is likely.
d032d5e7 Stefan Monnier2011-03-01 00:03:24 -0500855 (lambda (_vars)
94d11cb5
IK
Igor Kuzmin2011-02-10 13:53:49 -0500856 ;; `vars' will likely contain bindings which are
857 ;; not always available in other paths to
858 ;; `rest', so there' no point trying to pass
859 ;; them down.
860 (pcase--u rest))
872ab164
SM
Stefan Monnier2010-11-24 11:39:51 -0500861 vars
862 (list `((and . ,matches) ,code . ,vars))))
c87523bd Paul Eggert2015-08-21 20:19:46 -0700863 (t (error "Unknown pattern ‘%S’" upat)))))
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400864 (t (error "Incorrect MATCH %S" (car matches)))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200865
2e47de36
JB
Johan Bockgård2015-04-12 16:26:52 +0200866(def-edebug-spec
867 pcase-QPAT
dde09cdb Stefan Monnier2015-05-24 22:38:05 -0400868 (&or ("," pcase-PAT)
2e47de36
JB
Johan Bockgård2015-04-12 16:26:52 +0200869 (pcase-QPAT . pcase-QPAT)
870 (vector &rest pcase-QPAT)
871 sexp))
872
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400873(pcase-defmacro \` (qpat)
ae277259
SM
Stefan Monnier2015-03-23 18:24:30 -0400874 "Backquote-style pcase patterns.
875QPAT can take the following forms:
876 (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr.
877 [QPAT1 QPAT2..QPATn] matches a vector of length n and QPAT1..QPATn match
878 its 0..(n-1)th elements, respectively.
3ef31167
SM
Stefan Monnier2015-06-16 12:37:33 -0400879 ,PAT matches if the pcase pattern PAT matches.
880 ATOM matches if the object is `equal' to ATOM.
881 ATOM can be a symbol, an integer, or a string."
2e47de36 Johan Bockgård2015-04-12 16:26:52 +0200882 (declare (debug (pcase-QPAT)))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200883 (cond
7fbd780a Stefan Monnier2014-09-22 13:24:46 -0400884 ((eq (car-safe qpat) '\,) (cadr qpat))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200885 ((vectorp qpat)
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400886 `(and (pred vectorp)
887 (app length ,(length qpat))
888 ,@(let ((upats nil))
889 (dotimes (i (length qpat))
2b968ea6 Stefan Monnier2014-09-22 14:05:22 -0400890 (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400891 upats))
892 (nreverse upats))))
d02c9bcd Stefan Monnier2010-08-10 15:18:14 +0200893 ((consp qpat)
7fbd780a
SM
Stefan Monnier2014-09-22 13:24:46 -0400894 `(and (pred consp)
895 (app car ,(list '\` (car qpat)))
896 (app cdr ,(list '\` (cdr qpat)))))
3ef31167
SM
Stefan Monnier2015-06-16 12:37:33 -0400897 ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat)
898 (t (error "Unknown QPAT: %S" qpat))))
97eedd1b Glenn Morris2010-08-10 19:14:53 -0700899
d02c9bcd
SM
Stefan Monnier2010-08-10 15:18:14 +0200900
901(provide 'pcase)
902;;; pcase.el ends here