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