pcase.el 36.5 KB
Newer Older
1
;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
2

3
;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
4 5

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6
;; Keywords:
7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; ML-style pattern matching.
;; The entry points are autoloaded.

28 29
;; Todo:

30 31 32 33
;; - (pcase e (`(,x . ,x) foo)) signals an "x unused" warning if `foo' doesn't
;;   use x, because x is bound separately for the equality constraint
;;   (as well as any pred/guard) and for the body, so uses at one place don't
;;   count for the other.
34 35 36 37
;; - provide ways to extend the set of primitives, with some kind of
;;   define-pcase-matcher.  We could easily make it so that (guard BOOLEXP)
;;   could be defined this way, as a shorthand for (pred (lambda (_) BOOLEXP)).
;;   But better would be if we could define new ways to match by having the
38
;;   extension provide its own `pcase--split-<foo>' thingy.
39
;; - along these lines, provide patterns to match CL structs.
40 41
;; - provide something like (setq VAR) so a var can be set rather than
;;   let-bound.
42 43
;; - provide a way to fallthrough to subsequent cases (not sure what I meant by
;;   this :-()
44
;; - try and be more clever to reduce the size of the decision tree, and
45
;;   to reduce the number of leaves that need to be turned into function:
46
;;   - first, do the tests shared by all remaining branches (it will have
47
;;     to be performed anyway, so better do it first so it's shared).
48
;;   - then choose the test that discriminates more (?).
49 50
;; - provide Agda's `with' (along with its `...' companion).
;; - implement (not UPAT).  This might require a significant redesign.
51 52 53
;; - ideally we'd want (pcase s ((re RE1) E1) ((re RE2) E2)) to be able to
;;   generate a lex-style DFA to decide whether to run E1 or E2.

54 55
;;; Code:

56 57
(require 'macroexp)

58 59 60 61 62
;; Macro-expansion of pcase is reasonably fast, so it's not a problem
;; when byte-compiling a file, but when interpreting the code, if the pcase
;; is in a loop, the repeated macro-expansion becomes terribly costly, so we
;; memoize previous macro expansions to try and avoid recomputing them
;; over and over again.
63 64
;; FIXME: Now that macroexpansion is also performed when loading an interpreted
;; file, this is not a real problem any more.
65
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
66 67
;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
68

69
(defconst pcase--dontcare-upats '(t _ pcase--dontcare))
70

71 72
(defvar pcase--dontwarn-upats '(pcase--dontcare))

73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
(def-edebug-spec
  pcase-UPAT
  (&or symbolp
       ("or" &rest pcase-UPAT)
       ("and" &rest pcase-UPAT)
       ("`" pcase-QPAT)
       ("guard" form)
       ("let" pcase-UPAT form)
       ("pred"
        &or lambda-expr
        ;; Punt on macros/special forms.
        (functionp &rest form)
        sexp)
       sexp))

(def-edebug-spec
  pcase-QPAT
  (&or ("," pcase-UPAT)
       (pcase-QPAT . pcase-QPAT)
       sexp))

94 95 96 97 98 99 100
;;;###autoload
(defmacro pcase (exp &rest cases)
  "Perform ML-style pattern matching on EXP.
CASES is a list of elements of the form (UPATTERN CODE...).

UPatterns can take the following forms:
  _		matches anything.
101
  SELFQUOTING	matches itself.  This includes keywords, numbers, and strings.
102 103 104 105 106
  SYMBOL	matches anything and binds it to SYMBOL.
  (or UPAT...)	matches if any of the patterns matches.
  (and UPAT...)	matches if all the patterns match.
  `QPAT		matches if the QPattern QPAT matches.
  (pred PRED)	matches if PRED applied to the object returns non-nil.
107
  (guard BOOLEXP)	matches if BOOLEXP evaluates to non-nil.
108
  (let UPAT EXP)	matches if EXP matches UPAT.
109 110
If a SYMBOL is used twice in the same pattern (i.e. the pattern is
\"non-linear\"), then the second occurrence is turned into an `eq'uality test.
111 112

QPatterns can take the following forms:
Leo Liu's avatar
Leo Liu committed
113 114 115 116 117 118
  (QPAT1 . QPAT2)       matches if QPAT1 matches the car and QPAT2 the cdr.
  [QPAT1 QPAT2..QPATn]  matches a vector of length n and QPAT1..QPATn match
                           its 0..(n-1)th elements, respectively.
  ,UPAT                 matches if the UPattern UPAT matches.
  STRING                matches if the object is `equal' to STRING.
  ATOM                  matches if the object is `eq' to ATOM.
119 120

PRED can take the form
121
  FUNCTION	     in which case it gets called with one argument.
122 123
  (FUN ARG1 .. ARGN) in which case it gets called with an N+1'th argument
                        which is the value being matched.
124 125 126 127 128
A PRED of the form FUNCTION is equivalent to one of the form (FUNCTION).
PRED patterns can refer to variables bound earlier in the pattern.
E.g. you can match pairs where the cdr is larger than the car with a pattern
like `(,a . ,(pred (< a))) or, with more checks:
`(,(and a (pred numberp)) . ,(and (pred numberp) (pred (< a))))"
129
  (declare (indent 1) (debug (form &rest (pcase-UPAT body))))
130 131 132 133 134 135 136 137 138 139
  ;; We want to use a weak hash table as a cache, but the key will unavoidably
  ;; be based on `exp' and `cases', yet `cases' is a fresh new list each time
  ;; we're called so it'll be immediately GC'd.  So we use (car cases) as key
  ;; which does come straight from the source code and should hence not be GC'd
  ;; so easily.
  (let ((data (gethash (car cases) pcase--memoize)))
    ;; data = (EXP CASES . EXPANSION)
    (if (and (equal exp (car data)) (equal cases (cadr data)))
        ;; We have the right expansion.
        (cddr data)
140 141 142 143 144
      ;; (when (gethash (car cases) pcase--memoize-1)
      ;;   (message "pcase-memoize failed because of weak key!!"))
      ;; (when (gethash (car cases) pcase--memoize-2)
      ;;   (message "pcase-memoize failed because of eq test on %S"
      ;;            (car cases)))
145 146 147
      (when data
        (message "pcase-memoize: equal first branch, yet different"))
      (let ((expansion (pcase--expand exp cases)))
148 149 150
        (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize)
        ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-1)
        ;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
151
        expansion))))
152

153 154 155 156 157 158 159 160 161
;;;###autoload
(defmacro pcase-exhaustive (exp &rest cases)
  "The exhaustive version of `pcase' (which see)."
  (declare (indent 1) (debug pcase))
  (let* ((x (make-symbol "x"))
         (pcase--dontwarn-upats (cons x pcase--dontwarn-upats)))
    (pcase--expand
     exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))

162 163 164 165 166 167 168 169 170 171
(defun pcase--let* (bindings body)
  (cond
   ((null bindings) (macroexp-progn body))
   ((pcase--trivial-upat-p (caar bindings))
    (macroexp-let* `(,(car bindings)) (pcase--let* (cdr bindings) body)))
   (t
    (let ((binding (pop bindings)))
      (pcase--expand
       (cadr binding)
       `((,(car binding) ,(pcase--let* bindings body))
172 173 174 175 176 177
         ;; We can either signal an error here, or just use `pcase--dontcare'
         ;; which generates more efficient code.  In practice, if we use
         ;; `pcase--dontcare' we will still often get an error and the few
         ;; cases where we don't do not matter that much, so
         ;; it's a better choice.
         (pcase--dontcare nil)))))))
178

179
;;;###autoload
180
(defmacro pcase-let* (bindings &rest body)
181 182 183
  "Like `let*' but where you can use `pcase' patterns for bindings.
BODY should be an expression, and BINDINGS should be a list of bindings
of the form (UPAT EXP)."
184
  (declare (indent 1)
185
           (debug ((&rest (pcase-UPAT &optional form)) body)))
186 187 188 189 190 191 192
  (let ((cached (gethash bindings pcase--memoize)))
    ;; cached = (BODY . EXPANSION)
    (if (equal (car cached) body)
        (cdr cached)
      (let ((expansion (pcase--let* bindings body)))
        (puthash bindings (cons body expansion) pcase--memoize)
        expansion))))
193 194

;;;###autoload
195
(defmacro pcase-let (bindings &rest body)
196
  "Like `let' but where you can use `pcase' patterns for bindings.
197
BODY should be a list of expressions, and BINDINGS should be a list of bindings
198
of the form (UPAT EXP)."
199
  (declare (indent 1) (debug pcase-let*))
200
  (if (null (cdr bindings))
201 202 203 204 205 206 207 208 209 210 211 212 213 214
      `(pcase-let* ,bindings ,@body)
    (let ((matches '()))
      (dolist (binding (prog1 bindings (setq bindings nil)))
        (cond
         ((memq (car binding) pcase--dontcare-upats)
          (push (cons (make-symbol "_") (cdr binding)) bindings))
         ((pcase--trivial-upat-p (car binding)) (push binding bindings))
         (t
          (let ((tmpvar (make-symbol (format "x%d" (length bindings)))))
            (push (cons tmpvar (cdr binding)) bindings)
            (push (list (car binding) tmpvar) matches)))))
      `(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))

(defmacro pcase-dolist (spec &rest body)
215
  (declare (indent 1) (debug ((pcase-UPAT form) body)))
216 217 218 219 220 221 222 223 224 225 226 227
  (if (pcase--trivial-upat-p (car spec))
      `(dolist ,spec ,@body)
    (let ((tmpvar (make-symbol "x")))
      `(dolist (,tmpvar ,@(cdr spec))
         (pcase-let* ((,(car spec) ,tmpvar))
           ,@body)))))


(defun pcase--trivial-upat-p (upat)
  (and (symbolp upat) (not (memq upat pcase--dontcare-upats))))

(defun pcase--expand (exp cases)
228 229
  ;; (message "pid=%S (pcase--expand %S ...hash=%S)"
  ;;          (emacs-pid) exp (sxhash cases))
230
  (macroexp-let2 macroexp-copyable-p val exp
231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256
    (let* ((defs ())
           (seen '())
           (codegen
            (lambda (code vars)
              (let ((prev (assq code seen)))
                (if (not prev)
                    (let ((res (pcase-codegen code vars)))
                      (push (list code vars res) seen)
                      res)
                  ;; Since we use a tree-based pattern matching
                  ;; technique, the leaves (the places that contain the
                  ;; code to run once a pattern is matched) can get
                  ;; copied a very large number of times, so to avoid
                  ;; code explosion, we need to keep track of how many
                  ;; times we've used each leaf and move it
                  ;; to a separate function if that number is too high.
                  ;;
                  ;; We've already used this branch.  So it is shared.
                  (let* ((code (car prev))         (cdrprev (cdr prev))
                         (prevvars (car cdrprev))  (cddrprev (cdr cdrprev))
                         (res (car cddrprev)))
                    (unless (symbolp res)
                      ;; This is the first repeat, so we have to move
                      ;; the branch to a separate function.
                      (let ((bsym
                             (make-symbol (format "pcase-%d" (length defs)))))
257 258
                        (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code))
                              defs)
259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
                        (setcar res 'funcall)
                        (setcdr res (cons bsym (mapcar #'cdr prevvars)))
                        (setcar (cddr prev) bsym)
                        (setq res bsym)))
                    (setq vars (copy-sequence vars))
                    (let ((args (mapcar (lambda (pa)
                                          (let ((v (assq (car pa) vars)))
                                            (setq vars (delq v vars))
                                            (cdr v)))
                                        prevvars)))
                      ;; If some of `vars' were not found in `prevvars', that's
                      ;; OK it just means those vars aren't present in all
                      ;; branches, so they can be used within the pattern
                      ;; (e.g. by a `guard/let/pred') but not in the branch.
                      ;; FIXME: But if some of `prevvars' are not in `vars' we
                      ;; should remove them from `prevvars'!
                      `(funcall ,res ,@args)))))))
276
           (used-cases ())
277 278 279 280
           (main
            (pcase--u
             (mapcar (lambda (case)
                       `((match ,val . ,(car case))
281 282 283 284 285 286 287 288 289 290 291
                         ,(lambda (vars)
                            (unless (memq case used-cases)
                              ;; Keep track of the cases that are used.
                              (push case used-cases))
                            (funcall
                             (if (pcase--small-branch-p (cdr case))
                                 ;; Don't bother sharing multiple
                                 ;; occurrences of this leaf since it's small.
                                 #'pcase-codegen codegen)
                             (cdr case)
                             vars))))
292
                     cases))))
293
      (dolist (case cases)
294 295
        (unless (or (memq case used-cases)
                    (memq (car case) pcase--dontwarn-upats))
296
          (message "Redundant pcase pattern: %S" (car case))))
297
      (macroexp-let* defs main))))
298 299

(defun pcase-codegen (code vars)
300
  ;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
301 302 303
  ;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
  ;; codegen from later metamorphosing this let into a funcall.
  `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
304 305
     ,@code))

306
(defun pcase--small-branch-p (code)
307 308 309 310 311 312 313 314 315
  (and (= 1 (length code))
       (or (not (consp (car code)))
           (let ((small t))
             (dolist (e (car code))
               (if (consp e) (setq small nil)))
             small))))

;; Try to use `cond' rather than a sequence of `if's, so as to reduce
;; the depth of the generated tree.
316
(defun pcase--if (test then else)
317
  (cond
318
   ((eq else :pcase--dontcare) then)
319
   ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
320
   (t (macroexp-if test then else))))
321

322
(defun pcase--upat (qpattern)
323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344
  (cond
   ((eq (car-safe qpattern) '\,) (cadr qpattern))
   (t (list '\` qpattern))))

;; Note about MATCH:
;; When we have patterns like `(PAT1 . PAT2), after performing the `consp'
;; check, we want to turn all the similar patterns into ones of the form
;; (and (match car PAT1) (match cdr PAT2)), so you naturally need conjunction.
;; Earlier code hence used branches of the form (MATCHES . CODE) where
;; MATCHES was a list (implicitly a conjunction) of (SYM . PAT).
;; But if we have a pattern of the form (or `(PAT1 . PAT2) PAT3), there is
;; no easy way to eliminate the `consp' check in such a representation.
;; So we replaced the MATCHES by the MATCH below which can be made up
;; of conjunctions and disjunctions, so if we know `foo' is a cons, we can
;; turn (match foo . (or `(PAT1 . PAT2) PAT3)) into
;; (or (and (match car . `PAT1) (match cdr . `PAT2)) (match foo . PAT3)).
;; The downside is that we now have `or' and `and' both in MATCH and
;; in PAT, so there are different equivalent representations and we
;; need to handle them all.  We do not try to systematically
;; canonicalize them to one form over another, but we do occasionally
;; turn one into the other.

345
(defun pcase--u (branches)
346 347 348 349 350 351 352 353 354
  "Expand matcher for rules BRANCHES.
Each BRANCH has the form (MATCH CODE . VARS) where
CODE is the code generator for that branch.
VARS is the set of vars already bound by earlier matches.
MATCH is the pattern that needs to be matched, of the form:
  (match VAR . UPAT)
  (and MATCH ...)
  (or MATCH ...)"
  (when (setq branches (delq nil branches))
355 356 357 358
    (let* ((carbranch (car branches))
           (match (car carbranch)) (cdarbranch (cdr carbranch))
           (code (car cdarbranch))
           (vars (cdr cdarbranch)))
359
      (pcase--u1 (list match) code vars (cdr branches)))))
360

361
(defun pcase--and (match matches)
362 363
  (if matches `(and ,match ,@matches) match))

364 365 366 367 368
(defconst pcase-mutually-exclusive-predicates
  '((symbolp . integerp)
    (symbolp . numberp)
    (symbolp . consp)
    (symbolp . arrayp)
369
    (symbolp . vectorp)
370
    (symbolp . stringp)
371
    (symbolp . byte-code-function-p)
372 373
    (integerp . consp)
    (integerp . arrayp)
374
    (integerp . vectorp)
375
    (integerp . stringp)
376
    (integerp . byte-code-function-p)
377 378
    (numberp . consp)
    (numberp . arrayp)
379
    (numberp . vectorp)
380
    (numberp . stringp)
381
    (numberp . byte-code-function-p)
382
    (consp . arrayp)
383
    (consp . vectorp)
384
    (consp . stringp)
385 386
    (consp . byte-code-function-p)
    (arrayp . byte-code-function-p)
387 388
    (vectorp . byte-code-function-p)
    (stringp . vectorp)
389
    (stringp . byte-code-function-p)))
390

391 392 393 394 395 396
(defun pcase--mutually-exclusive-p (pred1 pred2)
  (or (member (cons pred1 pred2)
              pcase-mutually-exclusive-predicates)
      (member (cons pred2 pred1)
              pcase-mutually-exclusive-predicates)))

397
(defun pcase--split-match (sym splitter match)
398 399
  (cond
    ((eq (car match) 'match)
400 401 402 403 404 405
     (if (not (eq sym (cadr match)))
         (cons match match)
       (let ((pat (cddr match)))
         (cond
          ;; Hoist `or' and `and' patterns to `or' and `and' matches.
          ((memq (car-safe pat) '(or and))
406 407 408 409 410
           (pcase--split-match sym splitter
                               (cons (car pat)
                                     (mapcar (lambda (alt)
                                               `(match ,sym . ,alt))
                                             (cdr pat)))))
411 412
          (t (let ((res (funcall splitter (cddr match))))
               (cons (or (car res) match) (or (cdr res) match))))))))
413
    ((memq (car match) '(or and))
414 415
     (let ((then-alts '())
           (else-alts '())
416 417 418
           (neutral-elem (if (eq 'or (car match))
                             :pcase--fail :pcase--succeed))
           (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail)))
419
       (dolist (alt (cdr match))
420
         (let ((split (pcase--split-match sym splitter alt)))
421 422 423 424 425 426 427 428 429 430 431 432 433 434
           (unless (eq (car split) neutral-elem)
             (push (car split) then-alts))
           (unless (eq (cdr split) neutral-elem)
             (push (cdr split) else-alts))))
       (cons (cond ((memq zero-elem then-alts) zero-elem)
                   ((null then-alts) neutral-elem)
                   ((null (cdr then-alts)) (car then-alts))
                   (t (cons (car match) (nreverse then-alts))))
             (cond ((memq zero-elem else-alts) zero-elem)
                   ((null else-alts) neutral-elem)
                   ((null (cdr else-alts)) (car else-alts))
                   (t (cons (car match) (nreverse else-alts)))))))
    (t (error "Uknown MATCH %s" match))))

435
(defun pcase--split-rest (sym splitter rest)
436 437 438 439 440
  (let ((then-rest '())
        (else-rest '()))
    (dolist (branch rest)
      (let* ((match (car branch))
             (code&vars (cdr branch))
Paul Eggert's avatar
Paul Eggert committed
441
             (split
442
              (pcase--split-match sym splitter match)))
Paul Eggert's avatar
Paul Eggert committed
443 444 445 446
        (unless (eq (car split) :pcase--fail)
          (push (cons (car split) code&vars) then-rest))
        (unless (eq (cdr split) :pcase--fail)
          (push (cons (cdr split) code&vars) else-rest))))
447 448
    (cons (nreverse then-rest) (nreverse else-rest))))

449
(defun pcase--split-consp (syma symd pat)
450 451 452 453
  (cond
   ;; A QPattern for a cons, can only go the `then' side.
   ((and (eq (car-safe pat) '\`) (consp (cadr pat)))
    (let ((qpat (cadr pat)))
454 455 456
      (cons `(and (match ,syma . ,(pcase--upat (car qpat)))
                  (match ,symd . ,(pcase--upat (cdr qpat))))
            :pcase--fail)))
457
   ;; A QPattern but not for a cons, can only go to the `else' side.
458
   ((eq (car-safe pat) '\`) '(:pcase--fail . nil))
459
   ((and (eq (car-safe pat) 'pred)
460
         (pcase--mutually-exclusive-p #'consp (cadr pat)))
461
    '(:pcase--fail . nil))))
462

Leo Liu's avatar
Leo Liu committed
463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
(defun pcase--split-vector (syms pat)
  (cond
   ;; A QPattern for a vector of same length.
   ((and (eq (car-safe pat) '\`)
         (vectorp (cadr pat))
         (= (length syms) (length (cadr pat))))
    (let ((qpat (cadr pat)))
      (cons `(and ,@(mapcar (lambda (s)
                              `(match ,(car s) .
                                      ,(pcase--upat (aref qpat (cdr s)))))
                            syms))
            :pcase--fail)))
   ;; Other QPatterns go to the `else' side.
   ((eq (car-safe pat) '\`) '(:pcase--fail . nil))
   ((and (eq (car-safe pat) 'pred)
         (pcase--mutually-exclusive-p #'vectorp (cadr pat)))
    '(:pcase--fail . nil))))

481
(defun pcase--split-equal (elem pat)
482 483 484
  (cond
   ;; The same match will give the same result.
   ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem))
485
    '(:pcase--succeed . :pcase--fail))
486 487 488 489 490
   ;; A different match will fail if this one succeeds.
   ((and (eq (car-safe pat) '\`)
         ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
         ;;     (consp (cadr pat)))
         )
491
    '(:pcase--fail . nil))
492 493
   ((and (eq (car-safe pat) 'pred)
         (symbolp (cadr pat))
494
         (get (cadr pat) 'side-effect-free))
495 496 497 498
    (ignore-errors
      (if (funcall (cadr pat) elem)
	  '(:pcase--succeed . nil)
	'(:pcase--fail . nil))))))
499

500 501
(defun pcase--split-member (elems pat)
  ;; Based on pcase--split-equal.
502
  (cond
503 504
   ;; The same match (or a match of membership in a superset) will
   ;; give the same result, but we don't know how to check it.
505
   ;; (???
506
   ;;  '(:pcase--succeed . nil))
507
   ;; A match for one of the elements may succeed or fail.
508
   ((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
509
    nil)
510 511 512 513 514
   ;; A different match will fail if this one succeeds.
   ((and (eq (car-safe pat) '\`)
         ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
         ;;     (consp (cadr pat)))
         )
515
    '(:pcase--fail . nil))
516 517 518
   ((and (eq (car-safe pat) 'pred)
         (symbolp (cadr pat))
         (get (cadr pat) 'side-effect-free)
519 520 521 522 523
	 (ignore-errors
	   (let ((p (cadr pat)) (all t))
	     (dolist (elem elems)
	       (unless (funcall p elem) (setq all nil)))
	     all)))
524
    '(:pcase--succeed . nil))))
525

526
(defun pcase--split-pred (vars upat pat)
527 528
  (let (test)
    (cond
529 530 531 532 533 534 535 536 537 538
     ((and (equal upat pat)
           ;; For predicates like (pred (> a)), two such predicates may
           ;; actually refer to different variables `a'.
           (or (and (eq 'pred (car upat)) (symbolp (cadr upat)))
               ;; FIXME: `vars' gives us the environment in which `upat' will
               ;; run, but we don't have the environment in which `pat' will
               ;; run, so we can't do a reliable verification.  But let's try
               ;; and catch at least the easy cases such as (bug#14773).
               (not (pcase--fgrep (mapcar #'car vars) (cadr upat)))))
      '(:pcase--succeed . :pcase--fail))
539
     ((and (eq 'pred (car upat))
540 541 542 543 544 545 546 547
           (let ((otherpred
                  (cond ((eq 'pred (car-safe pat)) (cadr pat))
                        ((not (eq '\` (car-safe pat))) nil)
                        ((consp (cadr pat)) #'consp)
                        ((vectorp (cadr pat)) #'vectorp)
                        ((byte-code-function-p (cadr pat))
                         #'byte-code-function-p))))
             (pcase--mutually-exclusive-p (cadr upat) otherpred)))
548
      '(:pcase--fail . nil))
549 550 551 552 553 554 555 556
     ((and (eq 'pred (car upat))
           (eq '\` (car-safe pat))
           (symbolp (cadr upat))
           (or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
           (get (cadr upat) 'side-effect-free)
           (ignore-errors
             (setq test (list (funcall (cadr upat) (cadr pat))))))
      (if (car test)
557 558
          '(nil . :pcase--fail)
        '(:pcase--fail . nil))))))
559

560
(defun pcase--fgrep (vars sexp)
561 562 563
  "Check which of the symbols VARS appear in SEXP."
  (let ((res '()))
    (while (consp sexp)
564
      (dolist (var (pcase--fgrep vars (pop sexp)))
565 566 567 568
        (unless (memq var res) (push var res))))
    (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
    res))

569 570 571
(defun pcase--self-quoting-p (upat)
  (or (keywordp upat) (numberp upat) (stringp upat)))

572 573 574 575
(defsubst pcase--mark-used (sym)
  ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
  (if (symbolp sym) (put sym 'pcase-used t)))

576 577
;; It's very tempting to use `pcase' below, tho obviously, it'd create
;; bootstrapping problems.
578
(defun pcase--u1 (matches code vars rest)
579
  "Return code that runs CODE (with VARS) if MATCHES match.
580
Otherwise, it defers to REST which is a list of branches of the form
581 582 583 584 585 586 587 588
\(ELSE-MATCH ELSE-CODE . ELSE-VARS)."
  ;; Depending on the order in which we choose to check each of the MATCHES,
  ;; the resulting tree may be smaller or bigger.  So in general, we'd want
  ;; to be careful to chose the "optimal" order.  But predicate
  ;; patterns make this harder because they create dependencies
  ;; between matches.  So we don't bother trying to reorder anything.
  (cond
   ((null matches) (funcall code vars))
589 590 591
   ((eq :pcase--fail (car matches)) (pcase--u rest))
   ((eq :pcase--succeed (car matches))
    (pcase--u1 (cdr matches) code vars rest))
592
   ((eq 'and (caar matches))
593
    (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
594 595 596 597 598 599 600 601 602
   ((eq 'or (caar matches))
    (let* ((alts (cdar matches))
           (var (if (eq (caar alts) 'match) (cadr (car alts))))
           (simples '()) (others '()))
      (when var
        (dolist (alt alts)
          (if (and (eq (car alt) 'match) (eq var (cadr alt))
                   (let ((upat (cddr alt)))
                     (and (eq (car-safe upat) '\`)
603 604
                          (or (integerp (cadr upat)) (symbolp (cadr upat))
                              (stringp (cadr upat))))))
605 606 607
              (push (cddr alt) simples)
            (push alt others))))
      (cond
608
       ((null alts) (error "Please avoid it") (pcase--u rest))
609 610 611
       ((> (length simples) 1)
        ;; De-hoist the `or' MATCH into an `or' pattern that will be
        ;; turned into a `memq' below.
612 613 614
        (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
                   code vars
                   (if (null others) rest
615
                     (cons (cons
616 617 618 619
                            (pcase--and (if (cdr others)
                                            (cons 'or (nreverse others))
                                          (car others))
                                        (cdr matches))
620
                            (cons code vars))
621
                           rest))))
622
       (t
623 624
        (pcase--u1 (cons (pop alts) (cdr matches)) code vars
                   (if (null alts) (progn (error "Please avoid it") rest)
625
                     (cons (cons
626 627 628
                            (pcase--and (if (cdr alts)
                                            (cons 'or alts) (car alts))
                                        (cdr matches))
629
                            (cons code vars))
630
                           rest)))))))
631
   ((eq 'match (caar matches))
632
    (let* ((popmatches (pop matches))
633
           (_op (car popmatches))      (cdrpopmatches (cdr popmatches))
634 635
           (sym (car cdrpopmatches))
           (upat (cdr cdrpopmatches)))
636
      (cond
637
       ((memq upat '(t _)) (pcase--u1 matches code vars rest))
638
       ((eq upat 'pcase--dontcare) :pcase--dontcare)
639
       ((memq (car-safe upat) '(guard pred))
640
        (if (eq (car upat) 'pred) (pcase--mark-used sym))
641
        (let* ((splitrest
642
                (pcase--split-rest
643
                 sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
644 645
               (then-rest (car splitrest))
               (else-rest (cdr splitrest)))
646 647 648 649 650
          (pcase--if (if (and (eq (car upat) 'pred) (symbolp (cadr upat)))
                         `(,(cadr upat) ,sym)
                       (let* ((exp (cadr upat))
                              ;; `vs' is an upper bound on the vars we need.
                              (vs (pcase--fgrep (mapcar #'car vars) exp))
651 652 653 654 655 656 657 658 659 660
                              (env (mapcar (lambda (var)
                                             (list var (cdr (assq var vars))))
                                           vs))
                              (call (if (eq 'guard (car upat))
                                        exp
                                      (when (memq sym vs)
                                        ;; `sym' is shadowed by `env'.
                                        (let ((newsym (make-symbol "x")))
                                          (push (list newsym sym) env)
                                          (setq sym newsym)))
661 662
                                      (if (functionp exp)
                                          `(funcall #',exp ,sym)
663
                                        `(,@exp ,sym)))))
664 665 666 667 668
                         (if (null vs)
                             call
                           ;; Let's not replace `vars' in `exp' since it's
                           ;; too difficult to do it right, instead just
                           ;; let-bind `vars' around `exp'.
669
                           `(let* ,env ,call))))
670 671
                     (pcase--u1 matches code vars then-rest)
                     (pcase--u else-rest))))
672
       ((pcase--self-quoting-p upat)
673
        (pcase--mark-used sym)
674
        (pcase--q1 sym upat matches code vars rest))
675
       ((symbolp upat)
676
        (pcase--mark-used sym)
677 678 679 680 681 682
        (if (not (assq upat vars))
            (pcase--u1 matches code (cons (cons upat sym) vars) rest)
          ;; Non-linear pattern.  Turn it into an `eq' test.
          (pcase--u1 (cons `(match ,sym . (pred (eq ,(cdr (assq upat vars)))))
                           matches)
                     code vars rest)))
683 684 685 686
       ((eq (car-safe upat) 'let)
        ;; A upat of the form (let VAR EXP).
        ;; (pcase--u1 matches code
        ;;            (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
687
        (macroexp-let2
688 689 690 691 692 693 694 695 696 697
            macroexp-copyable-p sym
            (let* ((exp (nth 2 upat))
                   (found (assq exp vars)))
              (if found (cdr found)
                (let* ((vs (pcase--fgrep (mapcar #'car vars) exp))
                       (env (mapcar (lambda (v) (list v (cdr (assq v vars))))
                                    vs)))
                  (if env (macroexp-let* env exp) exp))))
          (pcase--u1 (cons `(match ,sym . ,(nth 1 upat)) matches)
                     code vars rest)))
698
       ((eq (car-safe upat) '\`)
699
        (pcase--mark-used sym)
700
        (pcase--q1 sym (cadr upat) matches code vars rest))
701
       ((eq (car-safe upat) 'or)
702 703
        (let ((all (> (length (cdr upat)) 1))
              (memq-fine t))
704 705
          (when all
            (dolist (alt (cdr upat))
706 707 708 709 710 711 712 713 714
              (unless (if (pcase--self-quoting-p alt)
                          (progn
                            (unless (or (symbolp alt) (integerp alt))
                              (setq memq-fine nil))
                            t)
                        (and (eq (car-safe alt) '\`)
                             (or (symbolp (cadr alt)) (integerp (cadr alt))
                                 (setq memq-fine nil)
                                 (stringp (cadr alt)))))
715 716 717
                (setq all nil))))
          (if all
              ;; Use memq for (or `a `b `c `d) rather than a big tree.
718 719
              (let* ((elems (mapcar (lambda (x) (if (consp x) (cadr x) x))
                                    (cdr upat)))
720 721
                     (splitrest
                      (pcase--split-rest
722
                       sym (lambda (pat) (pcase--split-member elems pat)) rest))
723 724
                     (then-rest (car splitrest))
                     (else-rest (cdr splitrest)))
725
                (pcase--mark-used sym)
726 727 728
                (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
                           (pcase--u1 matches code vars then-rest)
                           (pcase--u else-rest)))
729 730 731 732 733 734
            (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
                       (append (mapcar (lambda (upat)
                                         `((and (match ,sym . ,upat) ,@matches)
                                           ,code ,@vars))
                                       (cddr upat))
                               rest)))))
735
       ((eq (car-safe upat) 'and)
736 737 738 739
        (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat))
                                   (cdr upat))
                           matches)
                   code vars rest))
740 741 742
       ((eq (car-safe upat) 'not)
        ;; FIXME: The implementation below is naive and results in
        ;; inefficient code.
743
        ;; To make it work right, we would need to turn pcase--u1's
744 745 746 747 748 749
        ;; `code' and `vars' into a single argument of the same form as
        ;; `rest'.  We would also need to split this new `then-rest' argument
        ;; for every test (currently we don't bother to do it since
        ;; it's only useful for odd patterns like (and `(PAT1 . PAT2)
        ;; `(PAT3 . PAT4)) which the programmer can easily rewrite
        ;; to the more efficient `(,(and PAT1 PAT3) . ,(and PAT2 PAT4))).
750
        (pcase--u1 `((match ,sym . ,(cadr upat)))
751 752
                   ;; FIXME: This codegen is not careful to share its
                   ;; code if used several times: code blow up is likely.
753
                   (lambda (_vars)
754 755 756 757 758
                     ;; `vars' will likely contain bindings which are
                     ;; not always available in other paths to
                     ;; `rest', so there' no point trying to pass
                     ;; them down.
                     (pcase--u rest))
759 760
                   vars
                   (list `((and . ,matches) ,code . ,vars))))
761 762 763
       (t (error "Unknown upattern `%s'" upat)))))
   (t (error "Incorrect MATCH %s" (car matches)))))

764
(defun pcase--q1 (sym qpat matches code vars rest)
765
  "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
766
Otherwise, it defers to REST which is a list of branches of the form
767 768 769 770 771
\(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
  (cond
   ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
   ((floatp qpat) (error "Floating point patterns not supported"))
   ((vectorp qpat)
Leo Liu's avatar
Leo Liu committed
772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795
    (let* ((len (length qpat))
           (syms (mapcar (lambda (i) (cons (make-symbol (format "xaref%s" i)) i))
                         (number-sequence 0 (1- len))))
           (splitrest (pcase--split-rest
                       sym
                       (lambda (pat) (pcase--split-vector syms pat))
                       rest))
           (then-rest (car splitrest))
           (else-rest (cdr splitrest))
           (then-body (pcase--u1
                       `(,@(mapcar (lambda (s)
                                     `(match ,(car s) .
                                             ,(pcase--upat (aref qpat (cdr s)))))
                                   syms)
                         ,@matches)
                       code vars then-rest)))
      (pcase--if
       `(and (vectorp ,sym) (= (length ,sym) ,len))
       (macroexp-let* (delq nil (mapcar (lambda (s)
                                          (and (get (car s) 'pcase-used)
                                               `(,(car s) (aref ,sym ,(cdr s)))))
                                        syms))
                      then-body)
       (pcase--u else-rest))))
796
   ((consp qpat)
Stefan Monnier's avatar
Stefan Monnier committed
797 798 799 800
    (let* ((syma (make-symbol "xcar"))
           (symd (make-symbol "xcdr"))
           (splitrest (pcase--split-rest
                       sym
801
                       (lambda (pat) (pcase--split-consp syma symd pat))
Stefan Monnier's avatar
Stefan Monnier committed
802 803 804 805 806 807 808 809 810 811 812 813 814
                       rest))
           (then-rest (car splitrest))
           (else-rest (cdr splitrest))
           (then-body (pcase--u1 `((match ,syma . ,(pcase--upat (car qpat)))
                                   (match ,symd . ,(pcase--upat (cdr qpat)))
                                   ,@matches)
                                 code vars then-rest)))
      (pcase--if
       `(consp ,sym)
       ;; We want to be careful to only add bindings that are used.
       ;; The byte-compiler could do that for us, but it would have to pay
       ;; attention to the `consp' test in order to figure out that car/cdr
       ;; can't signal errors and our byte-compiler is not that clever.
815 816
       ;; FIXME: Some of those let bindings occur too early (they are used in
       ;; `then-body', but only within some sub-branch).
817
       (macroexp-let*
818
        `(,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
819
          ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
820
        then-body)
Stefan Monnier's avatar
Stefan Monnier committed
821
       (pcase--u else-rest))))
822
   ((or (integerp qpat) (symbolp qpat) (stringp qpat))
823 824 825 826
    (let* ((splitrest (pcase--split-rest
                       sym (lambda (pat) (pcase--split-equal qpat pat)) rest))
           (then-rest (car splitrest))
           (else-rest (cdr splitrest)))
827 828 829 830
      (pcase--if (cond
                  ((stringp qpat) `(equal ,sym ,qpat))
                  ((null qpat) `(null ,sym))
                  (t `(eq ,sym ',qpat)))
831 832
                 (pcase--u1 matches code vars then-rest)
                 (pcase--u else-rest))))
Paul Eggert's avatar
Paul Eggert committed
833
   (t (error "Unknown QPattern %s" qpat))))
834

835 836 837

(provide 'pcase)
;;; pcase.el ends here