pcase.el 31 KB

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