Commit | Line | Data |
---|---|---|
513749ee | 1 | ;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*- |
d02c9bcd | 2 | |
ba318903 | 3 | ;; Copyright (C) 2010-2014 Free Software Foundation, Inc. |
d02c9bcd SM |
4 | |
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
ca3afb79 | 6 | ;; Keywords: |
d02c9bcd SM |
7 | |
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 |
28 | ;; Todo: |
29 | ||
ca105506 SM |
30 | ;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't |
31 | ;; use x, because x is bound separately for the equality constraint | |
32 | ;; (as well as any pred/guard) and for the body, so uses at one place don't | |
33 | ;; count for the other. | |
dcc029e0 SM |
34 | ;; - provide ways to extend the set of primitives, with some kind of |
35 | ;; define-pcase-matcher. We could easily make it so that (guard BOOLEXP) | |
36 | ;; could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)). | |
37 | ;; But better would be if we could define new ways to match by having the | |
872ab164 | 38 | ;; extension provide its own `pcase--split-<foo>' thingy. |
ca105506 | 39 | ;; - along these lines, provide patterns to match CL structs. |
1f0816b6 SM |
40 | ;; - provide something like (setq VAR) so a var can be set rather than |
41 | ;; let-bound. | |
a179e3f7 SM |
42 | ;; - provide a way to fallthrough to subsequent cases (not sure what I meant by |
43 | ;; this :-() | |
1f0816b6 | 44 | ;; - try and be more clever to reduce the size of the decision tree, and |
ca105506 | 45 | ;; to reduce the number of leaves that need to be turned into function: |
1f0816b6 | 46 | ;; - first, do the tests shared by all remaining branches (it will have |
a179e3f7 | 47 | ;; to be performed anyway, so better do it first so it's shared). |
1f0816b6 | 48 | ;; - then choose the test that discriminates more (?). |
a179e3f7 SM |
49 | ;; - provide Agda's `with' (along with its `...' companion). |
50 | ;; - implement (not UPAT). This might require a significant redesign. | |
dcc029e0 SM |
51 | ;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to |
52 | ;; generate a lex-style DFA to decide whether to run E1 or E2. | |
53 | ||
d02c9bcd SM |
54 | ;;; Code: |
55 | ||
4dd1c416 SM |
56 | (require 'macroexp) |
57 | ||
d02c9bcd SM |
58 | ;; Macro-expansion of pcase is reasonably fast, so it's not a problem |
59 | ;; when byte-compiling a file, but when interpreting the code, if the pcase | |
60 | ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we | |
61 | ;; memoize previous macro expansions to try and avoid recomputing them | |
62 | ;; over and over again. | |
972debf2 SM |
63 | ;; FIXME: Now that macroexpansion is also performed when loading an interpreted |
64 | ;; file, this is not a real problem any more. | |
e2abe5a1 | 65 | (defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq)) |
82ad98e3 SM |
66 | ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq)) |
67 | ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal)) | |
d02c9bcd | 68 | |
a464a6c7 | 69 | (defconst pcase--dontcare-upats '(t _ pcase--dontcare)) |
872ab164 | 70 | |
a4712e11 JB |
71 | (def-edebug-spec |
72 | pcase-UPAT | |
73 | (&or symbolp | |
74 | ("or" &rest pcase-UPAT) | |
75 | ("and" &rest pcase-UPAT) | |
76 | ("`" pcase-QPAT) | |
77 | ("guard" form) | |
78 | ("let" pcase-UPAT form) | |
79 | ("pred" | |
80 | &or lambda-expr | |
81 | ;; Punt on macros/special forms. | |
82 | (functionp &rest form) | |
83 | sexp) | |
84 | sexp)) | |
85 | ||
86 | (def-edebug-spec | |
87 | pcase-QPAT | |
88 | (&or ("," pcase-UPAT) | |
89 | (pcase-QPAT . pcase-QPAT) | |
90 | sexp)) | |
91 | ||
d02c9bcd SM |
92 | ;;;###autoload |
93 | (defmacro pcase (exp &rest cases) | |
94 | "Perform ML-style pattern matching on EXP. | |
95 | CASES is a list of elements of the form (UPATTERN CODE...). | |
96 | ||
97 | UPatterns can take the following forms: | |
98 | _ matches anything. | |
19faa8e8 | 99 | SELFQUOTING matches itself. This includes keywords, numbers, and strings. |
d02c9bcd SM |
100 | SYMBOL matches anything and binds it to SYMBOL. |
101 | (or UPAT...) matches if any of the patterns matches. | |
102 | (and UPAT...) matches if all the patterns match. | |
103 | `QPAT matches if the QPattern QPAT matches. | |
104 | (pred PRED) matches if PRED applied to the object returns non-nil. | |
dcc029e0 | 105 | (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. |
ca105506 | 106 | (let UPAT EXP) matches if EXP matches UPAT. |
f9d554dd SM |
107 | If a SYMBOL is used twice in the same pattern (i.e. the pattern is |
108 | \"non-linear\"), then the second occurrence is turned into an `eq'uality test. | |
d02c9bcd SM |
109 | |
110 | QPatterns can take the following forms: | |
111 | (QPAT1 . QPAT2) matches if QPAT1 matches the car and QPAT2 the cdr. | |
112 | ,UPAT matches if the UPattern UPAT matches. | |
ca3afb79 | 113 | STRING matches if the object is `equal' to STRING. |
d02c9bcd SM |
114 | ATOM matches if the object is `eq' to ATOM. |
115 | QPatterns for vectors are not implemented yet. | |
116 | ||
117 | PRED can take the form | |
ca3afb79 | 118 | FUNCTION in which case it gets called with one argument. |
7abaf5cc SM |
119 | (FUN ARG1 .. ARGN) in which case it gets called with an N+1'th argument |
120 | which is the value being matched. | |
d02c9bcd SM |
121 | A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION). |
122 | PRED patterns can refer to variables bound earlier in the pattern. | |
123 | E.g. you can match pairs where the cdr is larger than the car with a pattern | |
124 | like `(,a . ,(pred (< a))) or, with more checks: | |
125 | `(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))" | |
a4712e11 | 126 | (declare (indent 1) (debug (form &rest (pcase-UPAT body)))) |
e2abe5a1 SM |
127 | ;; We want to use a weak hash table as a cache, but the key will unavoidably |
128 | ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time | |
129 | ;; we're called so it'll be immediately GC'd. So we use (car cases) as key | |
130 | ;; which does come straight from the source code and should hence not be GC'd | |
131 | ;; so easily. | |
132 | (let ((data (gethash (car cases) pcase--memoize))) | |
133 | ;; data = (EXP CASES . EXPANSION) | |
134 | (if (and (equal exp (car data)) (equal cases (cadr data))) | |
135 | ;; We have the right expansion. | |
136 | (cddr data) | |
82ad98e3 SM |
137 | ;; (when (gethash (car cases) pcase--memoize-1) |
138 | ;; (message "pcase-memoize failed because of weak key!!")) | |
139 | ;; (when (gethash (car cases) pcase--memoize-2) | |
140 | ;; (message "pcase-memoize failed because of eq test on %S" | |
141 | ;; (car cases))) | |
e2abe5a1 SM |
142 | (when data |
143 | (message "pcase-memoize: equal first branch, yet different")) | |
144 | (let ((expansion (pcase--expand exp cases))) | |
82ad98e3 SM |
145 | (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize) |
146 | ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1) | |
147 | ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2) | |
e2abe5a1 | 148 | expansion)))) |
d02c9bcd | 149 | |
82ad98e3 SM |
150 | (defun pcase--let* (bindings body) |
151 | (cond | |
152 | ((null bindings) (macroexp-progn body)) | |
153 | ((pcase--trivial-upat-p (caar bindings)) | |
154 | (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body))) | |
155 | (t | |
156 | (let ((binding (pop bindings))) | |
157 | (pcase--expand | |
158 | (cadr binding) | |
159 | `((,(car binding) ,(pcase--let* bindings body)) | |
a464a6c7 SM |
160 | ;; We can either signal an error here, or just use `pcase--dontcare' |
161 | ;; which generates more efficient code. In practice, if we use | |
162 | ;; `pcase--dontcare' we will still often get an error and the few | |
163 | ;; cases where we don't do not matter that much, so | |
164 | ;; it's a better choice. | |
165 | (pcase--dontcare nil))))))) | |
82ad98e3 | 166 | |
d02c9bcd | 167 | ;;;###autoload |
872ab164 | 168 | (defmacro pcase-let* (bindings &rest body) |
d02c9bcd SM |
169 | "Like `let*' but where you can use `pcase' patterns for bindings. |
170 | BODY should be an expression, and BINDINGS should be a list of bindings | |
171 | of the form (UPAT EXP)." | |
c41045e6 | 172 | (declare (indent 1) |
a4712e11 | 173 | (debug ((&rest (pcase-UPAT &optional form)) body))) |
82ad98e3 SM |
174 | (let ((cached (gethash bindings pcase--memoize))) |
175 | ;; cached = (BODY . EXPANSION) | |
176 | (if (equal (car cached) body) | |
177 | (cdr cached) | |
178 | (let ((expansion (pcase--let* bindings body))) | |
179 | (puthash bindings (cons body expansion) pcase--memoize) | |
180 | expansion)))) | |
d02c9bcd SM |
181 | |
182 | ;;;###autoload | |
872ab164 | 183 | (defmacro pcase-let (bindings &rest body) |
d02c9bcd | 184 | "Like `let' but where you can use `pcase' patterns for bindings. |
872ab164 | 185 | BODY should be a list of expressions, and BINDINGS should be a list of bindings |
d02c9bcd | 186 | of the form (UPAT EXP)." |
c41045e6 | 187 | (declare (indent 1) (debug pcase-let*)) |
d02c9bcd | 188 | (if (null (cdr bindings)) |
872ab164 SM |
189 | `(pcase-let* ,bindings ,@body) |
190 | (let ((matches '())) | |
191 | (dolist (binding (prog1 bindings (setq bindings nil))) | |
192 | (cond | |
193 | ((memq (car binding) pcase--dontcare-upats) | |
194 | (push (cons (make-symbol "_") (cdr binding)) bindings)) | |
195 | ((pcase--trivial-upat-p (car binding)) (push binding bindings)) | |
196 | (t | |
197 | (let ((tmpvar (make-symbol (format "x%d" (length bindings))))) | |
198 | (push (cons tmpvar (cdr binding)) bindings) | |
199 | (push (list (car binding) tmpvar) matches))))) | |
200 | `(let ,(nreverse bindings) (pcase-let* ,matches ,@body))))) | |
201 | ||
202 | (defmacro pcase-dolist (spec &rest body) | |
a4712e11 | 203 | (declare (indent 1) (debug ((pcase-UPAT form) body))) |
872ab164 SM |
204 | (if (pcase--trivial-upat-p (car spec)) |
205 | `(dolist ,spec ,@body) | |
206 | (let ((tmpvar (make-symbol "x"))) | |
207 | `(dolist (,tmpvar ,@(cdr spec)) | |
208 | (pcase-let* ((,(car spec) ,tmpvar)) | |
209 | ,@body))))) | |
210 | ||
211 | ||
212 | (defun pcase--trivial-upat-p (upat) | |
213 | (and (symbolp upat) (not (memq upat pcase--dontcare-upats)))) | |
214 | ||
215 | (defun pcase--expand (exp cases) | |
e2abe5a1 SM |
216 | ;; (message "pid=%S (pcase--expand %S ...hash=%S)" |
217 | ;; (emacs-pid) exp (sxhash cases)) | |
2ee3d7f0 | 218 | (macroexp-let2 macroexp-copyable-p val exp |
82ad98e3 SM |
219 | (let* ((defs ()) |
220 | (seen '()) | |
221 | (codegen | |
222 | (lambda (code vars) | |
223 | (let ((prev (assq code seen))) | |
224 | (if (not prev) | |
225 | (let ((res (pcase-codegen code vars))) | |
226 | (push (list code vars res) seen) | |
227 | res) | |
228 | ;; Since we use a tree-based pattern matching | |
229 | ;; technique, the leaves (the places that contain the | |
230 | ;; code to run once a pattern is matched) can get | |
231 | ;; copied a very large number of times, so to avoid | |
232 | ;; code explosion, we need to keep track of how many | |
233 | ;; times we've used each leaf and move it | |
234 | ;; to a separate function if that number is too high. | |
235 | ;; | |
236 | ;; We've already used this branch. So it is shared. | |
237 | (let* ((code (car prev)) (cdrprev (cdr prev)) | |
238 | (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) | |
239 | (res (car cddrprev))) | |
240 | (unless (symbolp res) | |
241 | ;; This is the first repeat, so we have to move | |
242 | ;; the branch to a separate function. | |
243 | (let ((bsym | |
244 | (make-symbol (format "pcase-%d" (length defs))))) | |
ee4b1330 SM |
245 | (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) |
246 | defs) | |
82ad98e3 SM |
247 | (setcar res 'funcall) |
248 | (setcdr res (cons bsym (mapcar #'cdr prevvars))) | |
249 | (setcar (cddr prev) bsym) | |
250 | (setq res bsym))) | |
251 | (setq vars (copy-sequence vars)) | |
252 | (let ((args (mapcar (lambda (pa) | |
253 | (let ((v (assq (car pa) vars))) | |
254 | (setq vars (delq v vars)) | |
255 | (cdr v))) | |
256 | prevvars))) | |
257 | ;; If some of `vars' were not found in `prevvars', that's | |
258 | ;; OK it just means those vars aren't present in all | |
259 | ;; branches, so they can be used within the pattern | |
260 | ;; (e.g. by a `guard/let/pred') but not in the branch. | |
261 | ;; FIXME: But if some of `prevvars' are not in `vars' we | |
262 | ;; should remove them from `prevvars'! | |
263 | `(funcall ,res ,@args))))))) | |
ee4b1330 | 264 | (used-cases ()) |
82ad98e3 SM |
265 | (main |
266 | (pcase--u | |
267 | (mapcar (lambda (case) | |
268 | `((match ,val . ,(car case)) | |
ee4b1330 SM |
269 | ,(lambda (vars) |
270 | (unless (memq case used-cases) | |
271 | ;; Keep track of the cases that are used. | |
272 | (push case used-cases)) | |
273 | (funcall | |
274 | (if (pcase--small-branch-p (cdr case)) | |
275 | ;; Don't bother sharing multiple | |
276 | ;; occurrences of this leaf since it's small. | |
277 | #'pcase-codegen codegen) | |
278 | (cdr case) | |
279 | vars)))) | |
82ad98e3 | 280 | cases)))) |
ee4b1330 | 281 | (dolist (case cases) |
a464a6c7 | 282 | (unless (or (memq case used-cases) (eq (car case) 'pcase--dontcare)) |
ee4b1330 | 283 | (message "Redundant pcase pattern: %S" (car case)))) |
4dd1c416 | 284 | (macroexp-let* defs main)))) |
d02c9bcd SM |
285 | |
286 | (defun pcase-codegen (code vars) | |
4dd1c416 | 287 | ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding |
6876a58d SM |
288 | ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy |
289 | ;; codegen from later metamorphosing this let into a funcall. | |
290 | `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) | |
d02c9bcd SM |
291 | ,@code)) |
292 | ||
872ab164 | 293 | (defun pcase--small-branch-p (code) |
d02c9bcd SM |
294 | (and (= 1 (length code)) |
295 | (or (not (consp (car code))) | |
296 | (let ((small t)) | |
297 | (dolist (e (car code)) | |
298 | (if (consp e) (setq small nil))) | |
299 | small)))) | |
300 | ||
301 | ;; Try to use `cond' rather than a sequence of `if's, so as to reduce | |
302 | ;; the depth of the generated tree. | |
872ab164 | 303 | (defun pcase--if (test then else) |
d02c9bcd | 304 | (cond |
872ab164 | 305 | ((eq else :pcase--dontcare) then) |
1f0816b6 | 306 | ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen? |
4dd1c416 | 307 | (t (macroexp-if test then else)))) |
5342bb06 | 308 | |
872ab164 | 309 | (defun pcase--upat (qpattern) |
d02c9bcd SM |
310 | (cond |
311 | ((eq (car-safe qpattern) '\,) (cadr qpattern)) | |
312 | (t (list '\` qpattern)))) | |
313 | ||
314 | ;; Note about MATCH: | |
315 | ;; When we have patterns like `(PAT1 . PAT2), after performing the `consp' | |
316 | ;; check, we want to turn all the similar patterns into ones of the form | |
317 | ;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction. | |
318 | ;; Earlier code hence used branches of the form (MATCHES . CODE) where | |
319 | ;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT). | |
320 | ;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is | |
321 | ;; no easy way to eliminate the `consp' check in such a representation. | |
322 | ;; So we replaced the MATCHES by the MATCH below which can be made up | |
323 | ;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can | |
324 | ;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into | |
325 | ;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)). | |
326 | ;; The downside is that we now have `or' and `and' both in MATCH and | |
327 | ;; in PAT, so there are different equivalent representations and we | |
328 | ;; need to handle them all. We do not try to systematically | |
329 | ;; canonicalize them to one form over another, but we do occasionally | |
330 | ;; turn one into the other. | |
331 | ||
872ab164 | 332 | (defun pcase--u (branches) |
d02c9bcd SM |
333 | "Expand matcher for rules BRANCHES. |
334 | Each BRANCH has the form (MATCH CODE . VARS) where | |
335 | CODE is the code generator for that branch. | |
336 | VARS is the set of vars already bound by earlier matches. | |
337 | MATCH is the pattern that needs to be matched, of the form: | |
338 | (match VAR . UPAT) | |
339 | (and MATCH ...) | |
340 | (or MATCH ...)" | |
341 | (when (setq branches (delq nil branches)) | |
9a05edc4 SM |
342 | (let* ((carbranch (car branches)) |
343 | (match (car carbranch)) (cdarbranch (cdr carbranch)) | |
344 | (code (car cdarbranch)) | |
345 | (vars (cdr cdarbranch))) | |
872ab164 | 346 | (pcase--u1 (list match) code vars (cdr branches))))) |
d02c9bcd | 347 | |
872ab164 | 348 | (defun pcase--and (match matches) |
d02c9bcd SM |
349 | (if matches `(and ,match ,@matches) match)) |
350 | ||
1f0816b6 SM |
351 | (defconst pcase-mutually-exclusive-predicates |
352 | '((symbolp . integerp) | |
353 | (symbolp . numberp) | |
354 | (symbolp . consp) | |
355 | (symbolp . arrayp) | |
671d5c16 | 356 | (symbolp . vectorp) |
1f0816b6 | 357 | (symbolp . stringp) |
ca105506 | 358 | (symbolp . byte-code-function-p) |
1f0816b6 SM |
359 | (integerp . consp) |
360 | (integerp . arrayp) | |
671d5c16 | 361 | (integerp . vectorp) |
1f0816b6 | 362 | (integerp . stringp) |
ca105506 | 363 | (integerp . byte-code-function-p) |
1f0816b6 SM |
364 | (numberp . consp) |
365 | (numberp . arrayp) | |
671d5c16 | 366 | (numberp . vectorp) |
1f0816b6 | 367 | (numberp . stringp) |
ca105506 | 368 | (numberp . byte-code-function-p) |
1f0816b6 | 369 | (consp . arrayp) |
671d5c16 | 370 | (consp . vectorp) |
1f0816b6 | 371 | (consp . stringp) |
ca105506 | 372 | (consp . byte-code-function-p) |
ca105506 | 373 | (arrayp . byte-code-function-p) |
671d5c16 SM |
374 | (vectorp . byte-code-function-p) |
375 | (stringp . vectorp) | |
ca105506 | 376 | (stringp . byte-code-function-p))) |
1f0816b6 | 377 | |
671d5c16 SM |
378 | (defun pcase--mutually-exclusive-p (pred1 pred2) |
379 | (or (member (cons pred1 pred2) | |
380 | pcase-mutually-exclusive-predicates) | |
381 | (member (cons pred2 pred1) | |
382 | pcase-mutually-exclusive-predicates))) | |
383 | ||
872ab164 | 384 | (defun pcase--split-match (sym splitter match) |
9a05edc4 SM |
385 | (cond |
386 | ((eq (car match) 'match) | |
d02c9bcd SM |
387 | (if (not (eq sym (cadr match))) |
388 | (cons match match) | |
389 | (let ((pat (cddr match))) | |
390 | (cond | |
391 | ;; Hoist `or' and `and' patterns to `or' and `and' matches. | |
392 | ((memq (car-safe pat) '(or and)) | |
872ab164 SM |
393 | (pcase--split-match sym splitter |
394 | (cons (car pat) | |
395 | (mapcar (lambda (alt) | |
396 | `(match ,sym . ,alt)) | |
397 | (cdr pat))))) | |
d02c9bcd SM |
398 | (t (let ((res (funcall splitter (cddr match)))) |
399 | (cons (or (car res) match) (or (cdr res) match)))))))) | |
9a05edc4 | 400 | ((memq (car match) '(or and)) |
d02c9bcd SM |
401 | (let ((then-alts '()) |
402 | (else-alts '()) | |
872ab164 SM |
403 | (neutral-elem (if (eq 'or (car match)) |
404 | :pcase--fail :pcase--succeed)) | |
405 | (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail))) | |
d02c9bcd | 406 | (dolist (alt (cdr match)) |
872ab164 | 407 | (let ((split (pcase--split-match sym splitter alt))) |
d02c9bcd SM |
408 | (unless (eq (car split) neutral-elem) |
409 | (push (car split) then-alts)) | |
410 | (unless (eq (cdr split) neutral-elem) | |
411 | (push (cdr split) else-alts)))) | |
412 | (cons (cond ((memq zero-elem then-alts) zero-elem) | |
413 | ((null then-alts) neutral-elem) | |
414 | ((null (cdr then-alts)) (car then-alts)) | |
415 | (t (cons (car match) (nreverse then-alts)))) | |
416 | (cond ((memq zero-elem else-alts) zero-elem) | |
417 | ((null else-alts) neutral-elem) | |
418 | ((null (cdr else-alts)) (car else-alts)) | |
419 | (t (cons (car match) (nreverse else-alts))))))) | |
420 | (t (error "Uknown MATCH %s" match)))) | |
421 | ||
872ab164 | 422 | (defun pcase--split-rest (sym splitter rest) |
d02c9bcd SM |
423 | (let ((then-rest '()) |
424 | (else-rest '())) | |
425 | (dolist (branch rest) | |
426 | (let* ((match (car branch)) | |
427 | (code&vars (cdr branch)) | |
bbd240ce | 428 | (split |
872ab164 | 429 | (pcase--split-match sym splitter match))) |
bbd240ce PE |
430 | (unless (eq (car split) :pcase--fail) |
431 | (push (cons (car split) code&vars) then-rest)) | |
432 | (unless (eq (cdr split) :pcase--fail) | |
433 | (push (cons (cdr split) code&vars) else-rest)))) | |
d02c9bcd SM |
434 | (cons (nreverse then-rest) (nreverse else-rest)))) |
435 | ||
872ab164 | 436 | (defun pcase--split-consp (syma symd pat) |
d02c9bcd SM |
437 | (cond |
438 | ;; A QPattern for a cons, can only go the `then' side. | |
439 | ((and (eq (car-safe pat) '\`) (consp (cadr pat))) | |
440 | (let ((qpat (cadr pat))) | |
872ab164 SM |
441 | (cons `(and (match ,syma . ,(pcase--upat (car qpat))) |
442 | (match ,symd . ,(pcase--upat (cdr qpat)))) | |
443 | :pcase--fail))) | |
1f0816b6 | 444 | ;; A QPattern but not for a cons, can only go to the `else' side. |
4bdc3526 | 445 | ((eq (car-safe pat) '\`) '(:pcase--fail . nil)) |
1f0816b6 | 446 | ((and (eq (car-safe pat) 'pred) |
671d5c16 | 447 | (pcase--mutually-exclusive-p #'consp (cadr pat))) |
4bdc3526 | 448 | '(:pcase--fail . nil)))) |
d02c9bcd | 449 | |
872ab164 | 450 | (defun pcase--split-equal (elem pat) |
d02c9bcd SM |
451 | (cond |
452 | ;; The same match will give the same result. | |
453 | ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem)) | |
4bdc3526 | 454 | '(:pcase--succeed . :pcase--fail)) |
d02c9bcd SM |
455 | ;; A different match will fail if this one succeeds. |
456 | ((and (eq (car-safe pat) '\`) | |
457 | ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) | |
458 | ;; (consp (cadr pat))) | |
459 | ) | |
4bdc3526 | 460 | '(:pcase--fail . nil)) |
1f0816b6 SM |
461 | ((and (eq (car-safe pat) 'pred) |
462 | (symbolp (cadr pat)) | |
4bdc3526 | 463 | (get (cadr pat) 'side-effect-free)) |
6f547583 SM |
464 | (ignore-errors |
465 | (if (funcall (cadr pat) elem) | |
466 | '(:pcase--succeed . nil) | |
467 | '(:pcase--fail . nil)))))) | |
d02c9bcd | 468 | |
872ab164 SM |
469 | (defun pcase--split-member (elems pat) |
470 | ;; Based on pcase--split-equal. | |
d02c9bcd | 471 | (cond |
dcc029e0 SM |
472 | ;; The same match (or a match of membership in a superset) will |
473 | ;; give the same result, but we don't know how to check it. | |
4de81ee0 | 474 | ;; (??? |
4bdc3526 | 475 | ;; '(:pcase--succeed . nil)) |
4de81ee0 | 476 | ;; A match for one of the elements may succeed or fail. |
d02c9bcd | 477 | ((and (eq (car-safe pat) '\`) (member (cadr pat) elems)) |
4de81ee0 | 478 | nil) |
d02c9bcd SM |
479 | ;; A different match will fail if this one succeeds. |
480 | ((and (eq (car-safe pat) '\`) | |
481 | ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) | |
482 | ;; (consp (cadr pat))) | |
483 | ) | |
4bdc3526 | 484 | '(:pcase--fail . nil)) |
1f0816b6 SM |
485 | ((and (eq (car-safe pat) 'pred) |
486 | (symbolp (cadr pat)) | |
487 | (get (cadr pat) 'side-effect-free) | |
6f547583 SM |
488 | (ignore-errors |
489 | (let ((p (cadr pat)) (all t)) | |
490 | (dolist (elem elems) | |
491 | (unless (funcall p elem) (setq all nil))) | |
492 | all))) | |
4bdc3526 | 493 | '(:pcase--succeed . nil)))) |
d02c9bcd | 494 | |
0b64b838 | 495 | (defun pcase--split-pred (vars upat pat) |
5342bb06 SM |
496 | (let (test) |
497 | (cond | |
0b64b838 SM |
498 | ((and (equal upat pat) |
499 | ;; For predicates like (pred (> a)), two such predicates may | |
500 | ;; actually refer to different variables `a'. | |
501 | (or (and (eq 'pred (car upat)) (symbolp (cadr upat))) | |
502 | ;; FIXME: `vars' gives us the environment in which `upat' will | |
503 | ;; run, but we don't have the environment in which `pat' will | |
504 | ;; run, so we can't do a reliable verification. But let's try | |
505 | ;; and catch at least the easy cases such as (bug#14773). | |
506 | (not (pcase--fgrep (mapcar #'car vars) (cadr upat))))) | |
507 | '(:pcase--succeed . :pcase--fail)) | |
5342bb06 | 508 | ((and (eq 'pred (car upat)) |
671d5c16 SM |
509 | (let ((otherpred |
510 | (cond ((eq 'pred (car-safe pat)) (cadr pat)) | |
511 | ((not (eq '\` (car-safe pat))) nil) | |
512 | ((consp (cadr pat)) #'consp) | |
513 | ((vectorp (cadr pat)) #'vectorp) | |
514 | ((byte-code-function-p (cadr pat)) | |
515 | #'byte-code-function-p)))) | |
516 | (pcase--mutually-exclusive-p (cadr upat) otherpred))) | |
4bdc3526 | 517 | '(:pcase--fail . nil)) |
5342bb06 SM |
518 | ((and (eq 'pred (car upat)) |
519 | (eq '\` (car-safe pat)) | |
520 | (symbolp (cadr upat)) | |
521 | (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat))) | |
522 | (get (cadr upat) 'side-effect-free) | |
523 | (ignore-errors | |
524 | (setq test (list (funcall (cadr upat) (cadr pat)))))) | |
525 | (if (car test) | |
4bdc3526 SM |
526 | '(nil . :pcase--fail) |
527 | '(:pcase--fail . nil)))))) | |
d02c9bcd | 528 | |
872ab164 | 529 | (defun pcase--fgrep (vars sexp) |
d02c9bcd SM |
530 | "Check which of the symbols VARS appear in SEXP." |
531 | (let ((res '())) | |
532 | (while (consp sexp) | |
872ab164 | 533 | (dolist (var (pcase--fgrep vars (pop sexp))) |
d02c9bcd SM |
534 | (unless (memq var res) (push var res)))) |
535 | (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) | |
536 | res)) | |
537 | ||
19faa8e8 SM |
538 | (defun pcase--self-quoting-p (upat) |
539 | (or (keywordp upat) (numberp upat) (stringp upat))) | |
540 | ||
7f457c06 SM |
541 | (defsubst pcase--mark-used (sym) |
542 | ;; Exceptionally, `sym' may be a constant expression rather than a symbol. | |
543 | (if (symbolp sym) (put sym 'pcase-used t))) | |
544 | ||
d02c9bcd SM |
545 | ;; It's very tempting to use `pcase' below, tho obviously, it'd create |
546 | ;; bootstrapping problems. | |
872ab164 | 547 | (defun pcase--u1 (matches code vars rest) |
d02c9bcd | 548 | "Return code that runs CODE (with VARS) if MATCHES match. |
ca3afb79 | 549 | Otherwise, it defers to REST which is a list of branches of the form |
d02c9bcd SM |
550 | \(ELSE-MATCH ELSE-CODE . ELSE-VARS)." |
551 | ;; Depending on the order in which we choose to check each of the MATCHES, | |
552 | ;; the resulting tree may be smaller or bigger. So in general, we'd want | |
553 | ;; to be careful to chose the "optimal" order. But predicate | |
554 | ;; patterns make this harder because they create dependencies | |
555 | ;; between matches. So we don't bother trying to reorder anything. | |
556 | (cond | |
557 | ((null matches) (funcall code vars)) | |
872ab164 SM |
558 | ((eq :pcase--fail (car matches)) (pcase--u rest)) |
559 | ((eq :pcase--succeed (car matches)) | |
560 | (pcase--u1 (cdr matches) code vars rest)) | |
d02c9bcd | 561 | ((eq 'and (caar matches)) |
872ab164 | 562 | (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest)) |
d02c9bcd SM |
563 | ((eq 'or (caar matches)) |
564 | (let* ((alts (cdar matches)) | |
565 | (var (if (eq (caar alts) 'match) (cadr (car alts)))) | |
566 | (simples '()) (others '())) | |
567 | (when var | |
568 | (dolist (alt alts) | |
569 | (if (and (eq (car alt) 'match) (eq var (cadr alt)) | |
570 | (let ((upat (cddr alt))) | |
571 | (and (eq (car-safe upat) '\`) | |
dcc029e0 SM |
572 | (or (integerp (cadr upat)) (symbolp (cadr upat)) |
573 | (stringp (cadr upat)))))) | |
d02c9bcd SM |
574 | (push (cddr alt) simples) |
575 | (push alt others)))) | |
576 | (cond | |
872ab164 | 577 | ((null alts) (error "Please avoid it") (pcase--u rest)) |
d02c9bcd SM |
578 | ((> (length simples) 1) |
579 | ;; De-hoist the `or' MATCH into an `or' pattern that will be | |
580 | ;; turned into a `memq' below. | |
872ab164 SM |
581 | (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches)) |
582 | code vars | |
583 | (if (null others) rest | |
9a05edc4 | 584 | (cons (cons |
872ab164 SM |
585 | (pcase--and (if (cdr others) |
586 | (cons 'or (nreverse others)) | |
587 | (car others)) | |
588 | (cdr matches)) | |
9a05edc4 | 589 | (cons code vars)) |
872ab164 | 590 | rest)))) |
d02c9bcd | 591 | (t |
872ab164 SM |
592 | (pcase--u1 (cons (pop alts) (cdr matches)) code vars |
593 | (if (null alts) (progn (error "Please avoid it") rest) | |
9a05edc4 | 594 | (cons (cons |
872ab164 SM |
595 | (pcase--and (if (cdr alts) |
596 | (cons 'or alts) (car alts)) | |
597 | (cdr matches)) | |
9a05edc4 | 598 | (cons code vars)) |
872ab164 | 599 | rest))))))) |
d02c9bcd | 600 | ((eq 'match (caar matches)) |
9a05edc4 | 601 | (let* ((popmatches (pop matches)) |
d032d5e7 | 602 | (_op (car popmatches)) (cdrpopmatches (cdr popmatches)) |
9a05edc4 SM |
603 | (sym (car cdrpopmatches)) |
604 | (upat (cdr cdrpopmatches))) | |
d02c9bcd | 605 | (cond |
872ab164 | 606 | ((memq upat '(t _)) (pcase--u1 matches code vars rest)) |
a464a6c7 | 607 | ((eq upat 'pcase--dontcare) :pcase--dontcare) |
dcc029e0 | 608 | ((memq (car-safe upat) '(guard pred)) |
7f457c06 | 609 | (if (eq (car upat) 'pred) (pcase--mark-used sym)) |
9a05edc4 | 610 | (let* ((splitrest |
ca105506 | 611 | (pcase--split-rest |
0b64b838 | 612 | sym (lambda (pat) (pcase--split-pred vars upat pat)) rest)) |
9a05edc4 SM |
613 | (then-rest (car splitrest)) |
614 | (else-rest (cdr splitrest))) | |
872ab164 SM |
615 | (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat))) |
616 | `(,(cadr upat) ,sym) | |
617 | (let* ((exp (cadr upat)) | |
618 | ;; `vs' is an upper bound on the vars we need. | |
619 | (vs (pcase--fgrep (mapcar #'car vars) exp)) | |
ca105506 SM |
620 | (env (mapcar (lambda (var) |
621 | (list var (cdr (assq var vars)))) | |
622 | vs)) | |
623 | (call (if (eq 'guard (car upat)) | |
624 | exp | |
625 | (when (memq sym vs) | |
626 | ;; `sym' is shadowed by `env'. | |
627 | (let ((newsym (make-symbol "x"))) | |
628 | (push (list newsym sym) env) | |
629 | (setq sym newsym))) | |
9abdc45d SM |
630 | (if (functionp exp) |
631 | `(funcall #',exp ,sym) | |
ca105506 | 632 | `(,@exp ,sym))))) |
872ab164 SM |
633 | (if (null vs) |
634 | call | |
635 | ;; Let's not replace `vars' in `exp' since it's | |
636 | ;; too difficult to do it right, instead just | |
637 | ;; let-bind `vars' around `exp'. | |
ca105506 | 638 | `(let* ,env ,call)))) |
872ab164 SM |
639 | (pcase--u1 matches code vars then-rest) |
640 | (pcase--u else-rest)))) | |
19faa8e8 | 641 | ((pcase--self-quoting-p upat) |
7f457c06 | 642 | (pcase--mark-used sym) |
19faa8e8 | 643 | (pcase--q1 sym upat matches code vars rest)) |
d02c9bcd | 644 | ((symbolp upat) |
7f457c06 | 645 | (pcase--mark-used sym) |
f9d554dd SM |
646 | (if (not (assq upat vars)) |
647 | (pcase--u1 matches code (cons (cons upat sym) vars) rest) | |
648 | ;; Non-linear pattern. Turn it into an `eq' test. | |
649 | (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars))))) | |
650 | matches) | |
651 | code vars rest))) | |
ca105506 SM |
652 | ((eq (car-safe upat) 'let) |
653 | ;; A upat of the form (let VAR EXP). | |
654 | ;; (pcase--u1 matches code | |
655 | ;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest) | |
2ee3d7f0 | 656 | (macroexp-let2 |
4dd1c416 SM |
657 | macroexp-copyable-p sym |
658 | (let* ((exp (nth 2 upat)) | |
659 | (found (assq exp vars))) | |
660 | (if found (cdr found) | |
661 | (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) | |
662 | (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) | |
663 | vs))) | |
664 | (if env (macroexp-let* env exp) exp)))) | |
665 | (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches) | |
666 | code vars rest))) | |
d02c9bcd | 667 | ((eq (car-safe upat) '\`) |
7f457c06 | 668 | (pcase--mark-used sym) |
872ab164 | 669 | (pcase--q1 sym (cadr upat) matches code vars rest)) |
d02c9bcd | 670 | ((eq (car-safe upat) 'or) |
dcc029e0 SM |
671 | (let ((all (> (length (cdr upat)) 1)) |
672 | (memq-fine t)) | |
d02c9bcd SM |
673 | (when all |
674 | (dolist (alt (cdr upat)) | |
249eea30 SM |
675 | (unless (if (pcase--self-quoting-p alt) |
676 | (progn | |
677 | (unless (or (symbolp alt) (integerp alt)) | |
678 | (setq memq-fine nil)) | |
679 | t) | |
680 | (and (eq (car-safe alt) '\`) | |
681 | (or (symbolp (cadr alt)) (integerp (cadr alt)) | |
682 | (setq memq-fine nil) | |
683 | (stringp (cadr alt))))) | |
d02c9bcd SM |
684 | (setq all nil)))) |
685 | (if all | |
686 | ;; Use memq for (or `a `b `c `d) rather than a big tree. | |
19faa8e8 SM |
687 | (let* ((elems (mapcar (lambda (x) (if (consp x) (cadr x) x)) |
688 | (cdr upat))) | |
9a05edc4 SM |
689 | (splitrest |
690 | (pcase--split-rest | |
ee4b1330 | 691 | sym (lambda (pat) (pcase--split-member elems pat)) rest)) |
9a05edc4 SM |
692 | (then-rest (car splitrest)) |
693 | (else-rest (cdr splitrest))) | |
7f457c06 | 694 | (pcase--mark-used sym) |
9a05edc4 SM |
695 | (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems) |
696 | (pcase--u1 matches code vars then-rest) | |
697 | (pcase--u else-rest))) | |
872ab164 SM |
698 | (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars |
699 | (append (mapcar (lambda (upat) | |
700 | `((and (match ,sym . ,upat) ,@matches) | |
701 | ,code ,@vars)) | |
702 | (cddr upat)) | |
703 | rest))))) | |
d02c9bcd | 704 | ((eq (car-safe upat) 'and) |
872ab164 SM |
705 | (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) |
706 | (cdr upat)) | |
707 | matches) | |
708 | code vars rest)) | |
d02c9bcd SM |
709 | ((eq (car-safe upat) 'not) |
710 | ;; FIXME: The implementation below is naive and results in | |
711 | ;; inefficient code. | |
872ab164 | 712 | ;; To make it work right, we would need to turn pcase--u1's |
d02c9bcd SM |
713 | ;; `code' and `vars' into a single argument of the same form as |
714 | ;; `rest'. We would also need to split this new `then-rest' argument | |
715 | ;; for every test (currently we don't bother to do it since | |
716 | ;; it's only useful for odd patterns like (and `(PAT1 . PAT2) | |
717 | ;; `(PAT3 . PAT4)) which the programmer can easily rewrite | |
718 | ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))). | |
872ab164 | 719 | (pcase--u1 `((match ,sym . ,(cadr upat))) |
94d11cb5 IK |
720 | ;; FIXME: This codegen is not careful to share its |
721 | ;; code if used several times: code blow up is likely. | |
d032d5e7 | 722 | (lambda (_vars) |
94d11cb5 IK |
723 | ;; `vars' will likely contain bindings which are |
724 | ;; not always available in other paths to | |
725 | ;; `rest', so there' no point trying to pass | |
726 | ;; them down. | |
727 | (pcase--u rest)) | |
872ab164 SM |
728 | vars |
729 | (list `((and . ,matches) ,code . ,vars)))) | |
d02c9bcd SM |
730 | (t (error "Unknown upattern `%s'" upat))))) |
731 | (t (error "Incorrect MATCH %s" (car matches))))) | |
732 | ||
872ab164 | 733 | (defun pcase--q1 (sym qpat matches code vars rest) |
d02c9bcd | 734 | "Return code that runs CODE if SYM matches QPAT and if MATCHES match. |
ca3afb79 | 735 | Otherwise, it defers to REST which is a list of branches of the form |
d02c9bcd SM |
736 | \(OTHER_MATCH OTHER-CODE . OTHER-VARS)." |
737 | (cond | |
738 | ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN")) | |
739 | ((floatp qpat) (error "Floating point patterns not supported")) | |
740 | ((vectorp qpat) | |
741 | ;; FIXME. | |
742 | (error "Vector QPatterns not implemented yet")) | |
743 | ((consp qpat) | |
0d6459df SM |
744 | (let* ((syma (make-symbol "xcar")) |
745 | (symd (make-symbol "xcdr")) | |
746 | (splitrest (pcase--split-rest | |
747 | sym | |
ee4b1330 | 748 | (lambda (pat) (pcase--split-consp syma symd pat)) |
0d6459df SM |
749 | rest)) |
750 | (then-rest (car splitrest)) | |
751 | (else-rest (cdr splitrest)) | |
752 | (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat))) | |
753 | (match ,symd . ,(pcase--upat (cdr qpat))) | |
754 | ,@matches) | |
755 | code vars then-rest))) | |
756 | (pcase--if | |
757 | `(consp ,sym) | |
758 | ;; We want to be careful to only add bindings that are used. | |
759 | ;; The byte-compiler could do that for us, but it would have to pay | |
760 | ;; attention to the `consp' test in order to figure out that car/cdr | |
761 | ;; can't signal errors and our byte-compiler is not that clever. | |
5342bb06 SM |
762 | ;; FIXME: Some of those let bindings occur too early (they are used in |
763 | ;; `then-body', but only within some sub-branch). | |
4dd1c416 | 764 | (macroexp-let* |
5342bb06 | 765 | `(,@(if (get syma 'pcase-used) `((,syma (car ,sym)))) |
6f547583 | 766 | ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym))))) |
5342bb06 | 767 | then-body) |
0d6459df | 768 | (pcase--u else-rest)))) |
dcc029e0 | 769 | ((or (integerp qpat) (symbolp qpat) (stringp qpat)) |
6f547583 SM |
770 | (let* ((splitrest (pcase--split-rest |
771 | sym (lambda (pat) (pcase--split-equal qpat pat)) rest)) | |
772 | (then-rest (car splitrest)) | |
773 | (else-rest (cdr splitrest))) | |
5342bb06 SM |
774 | (pcase--if (cond |
775 | ((stringp qpat) `(equal ,sym ,qpat)) | |
776 | ((null qpat) `(null ,sym)) | |
777 | (t `(eq ,sym ',qpat))) | |
872ab164 SM |
778 | (pcase--u1 matches code vars then-rest) |
779 | (pcase--u else-rest)))) | |
22bcf204 | 780 | (t (error "Unknown QPattern %s" qpat)))) |
97eedd1b | 781 | |
d02c9bcd SM |
782 | |
783 | (provide 'pcase) | |
784 | ;;; pcase.el ends here |