pcase.el 27.8 KB
Newer Older
1 2
;;; pcase.el --- ML-style pattern-matching macro for Elisp

3
;; Copyright (C) 2010-2011  Free Software Foundation, Inc.
4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: 

;; 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 30 31 32 33
;; Todo:

;; - 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
34
;;   extension provide its own `pcase--split-<foo>' thingy.
35 36 37 38 39 40 41 42
;; - provide something like (setq VAR) so a var can be set rather than
;;   let-bound.
;; - provide a way to fallthrough to other cases.
;; - try and be more clever to reduce the size of the decision tree, and
;;   to reduce the number of leafs that need to be turned into function:
;;   - first, do the tests shared by all remaining branches (it will have
;;     to be performed anyway, so better so it first so it's shared).
;;   - then choose the test that discriminates more (?).
43 44 45
;; - 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.

46 47 48 49 50 51 52 53 54 55 56
;;; Code:

(eval-when-compile (require 'cl))

;; 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.
(defconst pcase-memoize (make-hash-table :weakness t :test 'equal))

57 58
(defconst pcase--dontcare-upats '(t _ dontcare))

59 60 61 62 63 64 65 66 67 68 69 70
;;;###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.
  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.
71
  (guard BOOLEXP)	matches if BOOLEXP evaluates to non-nil.
72 73
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.
74 75 76 77

QPatterns can take the following forms:
  (QPAT1 . QPAT2)	matches if QPAT1 matches the car and QPAT2 the cdr.
  ,UPAT			matches if the UPattern UPAT matches.
78
  STRING			matches if the object is `equal' to STRING.
79 80 81 82 83 84 85 86 87 88 89
  ATOM			matches if the object is `eq' to ATOM.
QPatterns for vectors are not implemented yet.

PRED can take the form
  FUNCTION	in which case it gets called with one argument.
  (FUN ARG1 .. ARGN) in which case it gets called with N+1 arguments.
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))))"
90
  (declare (indent 1) (debug case))     ;FIXME: edebug `guard' and vars.
91 92
  (or (gethash (cons exp cases) pcase-memoize)
      (puthash (cons exp cases)
93
               (pcase--expand exp cases)
94 95 96
               pcase-memoize)))

;;;###autoload
97
(defmacro pcase-let* (bindings &rest body)
98 99 100
  "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)."
101
  (declare (indent 1) (debug let))
102 103 104 105 106
  (cond
   ((null bindings) (if (> (length body) 1) `(progn ,@body) (car body)))
   ((pcase--trivial-upat-p (caar bindings))
    `(let (,(car bindings)) (pcase-let* ,(cdr bindings) ,@body)))
   (t
107
    `(pcase ,(cadr (car bindings))
108 109 110 111 112 113
       (,(caar bindings) (pcase-let* ,(cdr bindings) ,@body))
       ;; We can either signal an error here, or just use `dontcare' which
       ;; generates more efficient code.  In practice, if we use `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.
       (dontcare nil)))))
114 115

;;;###autoload
116
(defmacro pcase-let (bindings &rest body)
117
  "Like `let' but where you can use `pcase' patterns for bindings.
118
BODY should be a list of expressions, and BINDINGS should be a list of bindings
119
of the form (UPAT EXP)."
120
  (declare (indent 1) (debug let))
121
  (if (null (cdr bindings))
122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
      `(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)
  (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)
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
  (let* ((defs (if (symbolp exp) '()
                 (let ((sym (make-symbol "x")))
                   (prog1 `((,sym ,exp)) (setq exp sym)))))
         (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.
                (destructuring-bind (code prevvars res) prev
                  (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)))))
                      (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs)
                      (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)))
                    (when vars          ;New additional vars.
                      (error "The vars %s are only bound in some paths"
                             (mapcar #'car vars)))
                    `(funcall ,res ,@args)))))))
         (main
190
          (pcase--u
191 192 193
           (mapcar (lambda (case)
                     `((match ,exp . ,(car case))
                       ,(apply-partially
194
                         (if (pcase--small-branch-p (cdr case))
195 196 197 198 199
                             ;; Don't bother sharing multiple
                             ;; occurrences of this leaf since it's small.
                             #'pcase-codegen codegen)
                         (cdr case))))
                   cases))))
200 201
    (if (null defs) main
      `(let ,defs ,main))))
202 203 204 205 206

(defun pcase-codegen (code vars)
  `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars)
     ,@code))

207
(defun pcase--small-branch-p (code)
208 209 210 211 212 213 214 215 216
  (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.
217
(defun pcase--if (test then else)
218
  (cond
219
   ((eq else :pcase--dontcare) then)
220
   ((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
221
   ((eq (car-safe else) 'if)
222 223
    (if (equal test (nth 1 else))
        ;; Doing a test a second time: get rid of the redundancy.
224 225 226
        ;; FIXME: ideally, this should never happen because the pcase--split-*
        ;; funs should have eliminated such things, but pcase--split-member
        ;; is imprecise, so in practice it can happen occasionally.
227 228 229 230
        `(if ,test ,then ,@(nthcdr 3 else))
      `(cond (,test ,then)
             (,(nth 1 else) ,(nth 2 else))
             (t ,@(nthcdr 3 else)))))
231 232
   ((eq (car-safe else) 'cond)
    `(cond (,test ,then)
233 234
           ;; Doing a test a second time: get rid of the redundancy, as above.
           ,@(remove (assoc test else) (cdr else))))
235 236
   ;; Invert the test if that lets us reduce the depth of the tree.
   ((memq (car-safe then) '(if cond)) (pcase--if `(not ,test) else then))
237 238
   (t `(if ,test ,then ,else))))

239
(defun pcase--upat (qpattern)
240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261
  (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.

262
(defun pcase--u (branches)
263 264 265 266 267 268 269 270 271 272
  "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))
    (destructuring-bind (match code &rest vars) (car branches)
273
      (pcase--u1 (list match) code vars (cdr branches)))))
274

275
(defun pcase--and (match matches)
276 277
  (if matches `(and ,match ,@matches) match))

278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293
(defconst pcase-mutually-exclusive-predicates
  '((symbolp . integerp)
    (symbolp . numberp)
    (symbolp . consp)
    (symbolp . arrayp)
    (symbolp . stringp)
    (integerp . consp)
    (integerp . arrayp)
    (integerp . stringp)
    (numberp . consp)
    (numberp . arrayp)
    (numberp . stringp)
    (consp . arrayp)
    (consp . stringp)
    (arrayp . stringp)))

294
(defun pcase--split-match (sym splitter match)
295 296 297 298 299 300 301 302
  (case (car match)
    ((match)
     (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))
303 304 305 306 307
           (pcase--split-match sym splitter
                               (cons (car pat)
                                     (mapcar (lambda (alt)
                                               `(match ,sym . ,alt))
                                             (cdr pat)))))
308 309 310 311 312
          (t (let ((res (funcall splitter (cddr match))))
               (cons (or (car res) match) (or (cdr res) match))))))))
    ((or and)
     (let ((then-alts '())
           (else-alts '())
313 314 315
           (neutral-elem (if (eq 'or (car match))
                             :pcase--fail :pcase--succeed))
           (zero-elem (if (eq 'or (car match)) :pcase--succeed :pcase--fail)))
316
       (dolist (alt (cdr match))
317
         (let ((split (pcase--split-match sym splitter alt)))
318 319 320 321 322 323 324 325 326 327 328 329 330 331
           (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))))

332
(defun pcase--split-rest (sym splitter rest)
333 334 335 336 337 338
  (let ((then-rest '())
        (else-rest '()))
    (dolist (branch rest)
      (let* ((match (car branch))
             (code&vars (cdr branch))
             (splitted
339 340
              (pcase--split-match sym splitter match)))
        (unless (eq (car splitted) :pcase--fail)
341
          (push (cons (car splitted) code&vars) then-rest))
342
        (unless (eq (cdr splitted) :pcase--fail)
343 344 345
          (push (cons (cdr splitted) code&vars) else-rest))))
    (cons (nreverse then-rest) (nreverse else-rest))))

346
(defun pcase--split-consp (syma symd pat)
347 348 349 350
  (cond
   ;; A QPattern for a cons, can only go the `then' side.
   ((and (eq (car-safe pat) '\`) (consp (cadr pat)))
    (let ((qpat (cadr pat)))
351 352 353
      (cons `(and (match ,syma . ,(pcase--upat (car qpat)))
                  (match ,symd . ,(pcase--upat (cdr qpat))))
            :pcase--fail)))
354 355 356 357 358 359 360 361
   ;; A QPattern but not for a cons, can only go to the `else' side.
   ((eq (car-safe pat) '\`) (cons :pcase--fail nil))
   ((and (eq (car-safe pat) 'pred)
         (or (member (cons 'consp (cadr pat))
                     pcase-mutually-exclusive-predicates)
             (member (cons (cadr pat) 'consp)
                     pcase-mutually-exclusive-predicates)))
    (cons :pcase--fail nil))))
362

363
(defun pcase--split-equal (elem pat)
364 365 366
  (cond
   ;; The same match will give the same result.
   ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem))
367
    (cons :pcase--succeed :pcase--fail))
368 369 370 371 372
   ;; A different match will fail if this one succeeds.
   ((and (eq (car-safe pat) '\`)
         ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
         ;;     (consp (cadr pat)))
         )
373 374 375 376 377 378
    (cons :pcase--fail nil))
   ((and (eq (car-safe pat) 'pred)
         (symbolp (cadr pat))
         (get (cadr pat) 'side-effect-free)
         (funcall (cadr pat) elem))
    (cons :pcase--succeed nil))))
379

380 381
(defun pcase--split-member (elems pat)
  ;; Based on pcase--split-equal.
382
  (cond
383 384
   ;; 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.
385
   ;; (???
386
   ;;  (cons :pcase--succeed nil))
387
   ;; A match for one of the elements may succeed or fail.
388
   ((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
389
    nil)
390 391 392 393 394
   ;; A different match will fail if this one succeeds.
   ((and (eq (car-safe pat) '\`)
         ;; (or (integerp (cadr pat)) (symbolp (cadr pat))
         ;;     (consp (cadr pat)))
         )
395 396 397 398 399 400 401 402 403
    (cons :pcase--fail nil))
   ((and (eq (car-safe pat) 'pred)
         (symbolp (cadr pat))
         (get (cadr pat) 'side-effect-free)
         (let ((p (cadr pat)) (all t))
           (dolist (elem elems)
             (unless (funcall p elem) (setq all nil)))
           all))
    (cons :pcase--succeed nil))))
404

405
(defun pcase--split-pred (upat pat)
406 407
  ;; FIXME: For predicates like (pred (> a)), two such predicates may
  ;; actually refer to different variables `a'.
408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427
  (cond
   ((equal upat pat) (cons :pcase--succeed :pcase--fail))
   ((and (eq 'pred (car upat))
         (eq 'pred (car-safe pat))
         (or (member (cons (cadr upat) (cadr pat))
                     pcase-mutually-exclusive-predicates)
             (member (cons (cadr pat) (cadr upat))
                     pcase-mutually-exclusive-predicates)))
    (cons :pcase--fail nil))
   ;; ((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)
   ;;       (progn (message "Trying predicate %S" (cadr upat))
   ;;              (ignore-errors
   ;;                (funcall (cadr upat) (cadr pat)))))
   ;;  (message "Simplify pred %S against %S" upat pat)
   ;;  (cons nil :pcase--fail))
   ))
428

429
(defun pcase--fgrep (vars sexp)
430 431 432
  "Check which of the symbols VARS appear in SEXP."
  (let ((res '()))
    (while (consp sexp)
433
      (dolist (var (pcase--fgrep vars (pop sexp)))
434 435 436 437 438 439
        (unless (memq var res) (push var res))))
    (and (memq sexp vars) (not (memq sexp res)) (push sexp res))
    res))

;; It's very tempting to use `pcase' below, tho obviously, it'd create
;; bootstrapping problems.
440
(defun pcase--u1 (matches code vars rest)
441 442 443 444 445 446 447 448 449 450
  "Return code that runs CODE (with VARS) if MATCHES match.
and otherwise defers to REST which is a list of branches of the form
\(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))
451 452 453
   ((eq :pcase--fail (car matches)) (pcase--u rest))
   ((eq :pcase--succeed (car matches))
    (pcase--u1 (cdr matches) code vars rest))
454
   ((eq 'and (caar matches))
455
    (pcase--u1 (append (cdar matches) (cdr matches)) code vars rest))
456 457 458 459 460 461 462 463 464
   ((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) '\`)
465 466
                          (or (integerp (cadr upat)) (symbolp (cadr upat))
                              (stringp (cadr upat))))))
467 468 469
              (push (cddr alt) simples)
            (push alt others))))
      (cond
470
       ((null alts) (error "Please avoid it") (pcase--u rest))
471 472 473
       ((> (length simples) 1)
        ;; De-hoist the `or' MATCH into an `or' pattern that will be
        ;; turned into a `memq' below.
474 475 476 477 478 479 480 481 482 483
        (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
                   code vars
                   (if (null others) rest
                     (cons (list*
                            (pcase--and (if (cdr others)
                                            (cons 'or (nreverse others))
                                          (car others))
                                        (cdr matches))
                            code vars)
                           rest))))
484
       (t
485 486 487 488 489 490 491 492
        (pcase--u1 (cons (pop alts) (cdr matches)) code vars
                   (if (null alts) (progn (error "Please avoid it") rest)
                     (cons (list*
                            (pcase--and (if (cdr alts)
                                            (cons 'or alts) (car alts))
                                        (cdr matches))
                            code vars)
                           rest)))))))
493 494 495
   ((eq 'match (caar matches))
    (destructuring-bind (op sym &rest upat) (pop matches)
      (cond
496 497
       ((memq upat '(t _)) (pcase--u1 matches code vars rest))
       ((eq upat 'dontcare) :pcase--dontcare)
498
       ((functionp upat)  (error "Feature removed, use (pred %s)" upat))
499
       ((memq (car-safe upat) '(guard pred))
500
        (if (eq (car upat) 'pred) (put sym 'pcase-used t))
501
        (destructuring-bind (then-rest &rest else-rest)
502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525
            (pcase--split-rest
             sym (apply-partially #'pcase--split-pred upat) rest)
          (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))
                              (call (cond
                                     ((eq 'guard (car upat)) exp)
                                     ((functionp exp) `(,exp ,sym))
                                     (t `(,@exp ,sym)))))
                         (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'.
                           `(let ,(mapcar (lambda (var)
                                            (list var (cdr (assq var vars))))
                                          vs)
                              ;; FIXME: `vars' can capture `sym'.  E.g.
                              ;; (pcase x ((and `(,x . ,y) (pred (fun x)))))
                              ,call))))
                     (pcase--u1 matches code vars then-rest)
                     (pcase--u else-rest))))
526
       ((symbolp upat)
527
        (put sym 'pcase-used t)
528 529 530 531 532 533
        (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)))
534
       ((eq (car-safe upat) '\`)
535
        (put sym 'pcase-used t)
536
        (pcase--q1 sym (cadr upat) matches code vars rest))
537
       ((eq (car-safe upat) 'or)
538 539
        (let ((all (> (length (cdr upat)) 1))
              (memq-fine t))
540 541 542
          (when all
            (dolist (alt (cdr upat))
              (unless (and (eq (car-safe alt) '\`)
543 544 545
                           (or (symbolp (cadr alt)) (integerp (cadr alt))
                               (setq memq-fine nil)
                               (stringp (cadr alt))))
546 547 548 549 550
                (setq all nil))))
          (if all
              ;; Use memq for (or `a `b `c `d) rather than a big tree.
              (let ((elems (mapcar 'cadr (cdr upat))))
                (destructuring-bind (then-rest &rest else-rest)
551 552 553 554 555 556 557 558 559 560 561
                    (pcase--split-rest
                     sym (apply-partially #'pcase--split-member elems) rest)
                  (pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
                             (pcase--u1 matches code vars then-rest)
                             (pcase--u else-rest))))
            (pcase--u1 (cons `(match ,sym ,@(cadr upat)) matches) code vars
                       (append (mapcar (lambda (upat)
                                         `((and (match ,sym . ,upat) ,@matches)
                                           ,code ,@vars))
                                       (cddr upat))
                               rest)))))
562
       ((eq (car-safe upat) 'and)
563 564 565 566
        (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat))
                                   (cdr upat))
                           matches)
                   code vars rest))
567 568 569
       ((eq (car-safe upat) 'not)
        ;; FIXME: The implementation below is naive and results in
        ;; inefficient code.
570
        ;; To make it work right, we would need to turn pcase--u1's
571 572 573 574 575 576
        ;; `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))).
577 578 579 580 581 582 583 584 585 586 587 588
        (pcase--u1 `((match ,sym . ,(cadr upat)))
                   (lexical-let ((rest rest))
                     ;; FIXME: This codegen is not careful to share its
                     ;; code if used several times: code blow up is likely.
                     (lambda (vars)
                       ;; `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)))
                   vars
                   (list `((and . ,matches) ,code . ,vars))))
589 590 591
       (t (error "Unknown upattern `%s'" upat)))))
   (t (error "Incorrect MATCH %s" (car matches)))))

592
(defun pcase--q1 (sym qpat matches code vars rest)
593 594 595 596 597 598 599 600 601 602 603 604 605
  "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
and if not, defers to REST which is a list of branches of the form
\(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)
    ;; FIXME.
    (error "Vector QPatterns not implemented yet"))
   ((consp qpat)
    (let ((syma (make-symbol "xcar"))
          (symd (make-symbol "xcdr")))
      (destructuring-bind (then-rest &rest else-rest)
606 607 608
          (pcase--split-rest sym
                             (apply-partially #'pcase--split-consp syma symd)
                             rest)
609 610 611 612 613 614 615 616 617 618 619 620 621 622
        (let ((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.
           `(let (,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
                  ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
              ,then-body)
           (pcase--u else-rest))))))
623
   ((or (integerp qpat) (symbolp qpat) (stringp qpat))
624
    (destructuring-bind (then-rest &rest else-rest)
625 626 627 628
        (pcase--split-rest sym (apply-partially 'pcase--split-equal qpat) rest)
      (pcase--if `(,(if (stringp qpat) #'equal #'eq) ,sym ',qpat)
                 (pcase--u1 matches code vars then-rest)
                 (pcase--u else-rest))))
629
   (t (error "Unkown QPattern %s" qpat))))
630

631 632 633

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