-;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
+;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t -*-
-;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:
;; to be performed anyway, so better do it first so it's shared).
;; - then choose the test that discriminates more (?).
;; - provide Agda's `with' (along with its `...' companion).
-;; - implement (not UPAT). This might require a significant redesign.
+;; - implement (not PAT). This might require a significant redesign.
;; - 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.
(defconst pcase--dontcare-upats '(t _ pcase--dontcare))
+(defvar pcase--dontwarn-upats '(pcase--dontcare))
+
(def-edebug-spec
- pcase-UPAT
+ pcase-PAT
(&or symbolp
- ("or" &rest pcase-UPAT)
- ("and" &rest pcase-UPAT)
- ("`" pcase-QPAT)
+ ("or" &rest pcase-PAT)
+ ("and" &rest pcase-PAT)
("guard" form)
- ("let" pcase-UPAT form)
- ("pred"
- &or lambda-expr
- ;; Punt on macros/special forms.
- (functionp &rest form)
- sexp)
+ ("let" pcase-PAT form)
+ ("pred" pcase-FUN)
+ ("app" pcase-FUN pcase-PAT)
+ pcase-MACRO
sexp))
(def-edebug-spec
- pcase-QPAT
- (&or ("," pcase-UPAT)
- (pcase-QPAT . pcase-QPAT)
+ pcase-FUN
+ (&or lambda-expr
+ ;; Punt on macros/special forms.
+ (functionp &rest form)
sexp))
+(def-edebug-spec pcase-MACRO pcase--edebug-match-macro)
+
+;; Only called from edebug.
+(declare-function get-edebug-spec "edebug" (symbol))
+(declare-function edebug-match "edebug" (cursor specs))
+
+(defun pcase--edebug-match-macro (cursor)
+ (let (specs)
+ (mapatoms
+ (lambda (s)
+ (let ((m (get s 'pcase-macroexpander)))
+ (when (and m (get-edebug-spec m))
+ (push (cons (symbol-name s) (get-edebug-spec m))
+ specs)))))
+ (edebug-match cursor (cons '&or specs))))
+
;;;###autoload
(defmacro pcase (exp &rest cases)
- "Perform ML-style pattern matching on EXP.
-CASES is a list of elements of the form (UPATTERN CODE...).
+ "Evaluate EXP and attempt to match it against structural patterns.
+CASES is a list of elements of the form (PATTERN CODE...).
+
+A structural PATTERN describes a template that identifies a class
+of values. For example, the pattern \\=`(,foo ,bar) matches any
+two element list, binding its elements to symbols named `foo' and
+`bar' -- in much the same way that `cl-destructuring-bind' would.
+
+A significant difference from `cl-destructuring-bind' is that, if
+a pattern match fails, the next case is tried until either a
+successful match is found or there are no more cases.
+
+Another difference is that pattern elements may be quoted,
+meaning they must match exactly: The pattern \\='(foo bar)
+matches only against two element lists containing the symbols
+`foo' and `bar' in that order. (As a short-hand, atoms always
+match themselves, such as numbers or strings, and need not be
+quoted.)
+
+Lastly, a pattern can be logical, such as (pred numberp), that
+matches any number-like element; or the symbol `_', that matches
+anything. Also, when patterns are backquoted, a comma may be
+used to introduce logical patterns inside backquoted patterns.
+
+The complete list of standard patterns is as follows:
-UPatterns can take the following forms:
_ matches anything.
- SELFQUOTING matches itself. This includes keywords, numbers, and strings.
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.
+ If a SYMBOL is used twice in the same pattern
+ the second occurrence becomes an `eq'uality test.
+ (or PAT...) matches if any of the patterns matches.
+ (and PAT...) matches if all the patterns match.
+ \\='VAL matches if the object is `equal' to VAL.
+ ATOM is a shorthand for \\='ATOM.
+ ATOM can be a keyword, an integer, or a string.
+ (pred FUN) matches if FUN applied to the object returns non-nil.
(guard BOOLEXP) matches if BOOLEXP evaluates to non-nil.
- (let UPAT EXP) matches if EXP matches UPAT.
-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.
-
-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.
- STRING matches if the object is `equal' to STRING.
- 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 an N+1'th argument
+ (let PAT EXP) matches if EXP matches PAT.
+ (app FUN PAT) matches if FUN applied to the object matches PAT.
+
+Additional patterns can be defined using `pcase-defmacro'.
+
+The FUN argument in the `app' pattern may have the following forms:
+ SYMBOL or (lambda ARGS BODY) in which case it's called with one argument.
+ (F ARG1 .. ARGn) in which case F gets called with an n+1'th argument
which is the value being matched.
-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))))"
- (declare (indent 1) (debug (form &rest (pcase-UPAT body))))
+So a FUN of the form SYMBOL is equivalent to (FUN).
+FUN can refer to variables bound earlier in the pattern.
+
+See Info node `(elisp) Pattern matching case statement' in the
+Emacs Lisp manual for more information and examples."
+ (declare (indent 1) (debug (form &rest (pcase-PAT body))))
;; 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
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
expansion))))
+(declare-function help-fns--signature "help-fns"
+ (function doc real-def real-function buffer))
+
+;; FIXME: Obviously, this will collide with nadvice's use of
+;; function-documentation if we happen to advise `pcase'.
+(put 'pcase 'function-documentation '(pcase--make-docstring))
+(defun pcase--make-docstring ()
+ (let* ((main (documentation (symbol-function 'pcase) 'raw))
+ (ud (help-split-fundoc main 'pcase)))
+ ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works,
+ ;; where cl-lib is anything using pcase-defmacro.
+ (require 'help-fns)
+ (with-temp-buffer
+ (insert (or (cdr ud) main))
+ (mapatoms
+ (lambda (symbol)
+ (let ((me (get symbol 'pcase-macroexpander)))
+ (when me
+ (insert "\n\n-- ")
+ (let* ((doc (documentation me 'raw)))
+ (setq doc (help-fns--signature symbol doc me
+ (indirect-function me) nil))
+ (insert "\n" (or doc "Not documented.")))))))
+ (let ((combined-doc (buffer-string)))
+ (if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
+
+;;;###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
+ ;; FIXME: Could we add the FILE:LINE data in the error message?
+ exp (append cases `((,x (error "No clause matching `%S'" ,x)))))))
+
+;;;###autoload
+(defmacro pcase-lambda (lambda-list &rest body)
+ "Like `lambda' but allow each argument to be a pattern.
+I.e. accepts the usual &optional and &rest keywords, but every
+formal argument can be any pattern accepted by `pcase' (a mere
+variable name being but a special case of it)."
+ (declare (doc-string 2) (indent defun)
+ (debug ((&rest pcase-PAT) body)))
+ (let* ((bindings ())
+ (parsed-body (macroexp-parse-body body))
+ (args (mapcar (lambda (pat)
+ (if (symbolp pat)
+ ;; Simple vars and &rest/&optional are just passed
+ ;; through unchanged.
+ pat
+ (let ((arg (make-symbol
+ (format "arg%s" (length bindings)))))
+ (push `(,pat ,arg) bindings)
+ arg)))
+ lambda-list)))
+ `(lambda ,args ,@(car parsed-body)
+ (pcase-let* ,(nreverse bindings) ,@(cdr parsed-body)))))
+
(defun pcase--let* (bindings body)
(cond
((null bindings) (macroexp-progn body))
(defmacro pcase-let* (bindings &rest body)
"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)."
+of the form (PAT EXP)."
(declare (indent 1)
- (debug ((&rest (pcase-UPAT &optional form)) body)))
+ (debug ((&rest (pcase-PAT &optional form)) body)))
(let ((cached (gethash bindings pcase--memoize)))
;; cached = (BODY . EXPANSION)
(if (equal (car cached) body)
(defmacro pcase-let (bindings &rest body)
"Like `let' but where you can use `pcase' patterns for bindings.
BODY should be a list of expressions, and BINDINGS should be a list of bindings
-of the form (UPAT EXP)."
+of the form (PAT EXP).
+The macro is expanded and optimized under the assumption that those
+patterns *will* match, so a mismatch may go undetected or may cause
+any kind of error."
(declare (indent 1) (debug pcase-let*))
(if (null (cdr bindings))
`(pcase-let* ,bindings ,@body)
(push (list (car binding) tmpvar) matches)))))
`(let ,(nreverse bindings) (pcase-let* ,matches ,@body)))))
+;;;###autoload
(defmacro pcase-dolist (spec &rest body)
- (declare (indent 1) (debug ((pcase-UPAT form) body)))
+ (declare (indent 1) (debug ((pcase-PAT form) body)))
(if (pcase--trivial-upat-p (car spec))
`(dolist ,spec ,@body)
(let ((tmpvar (make-symbol "x")))
(main
(pcase--u
(mapcar (lambda (case)
- `((match ,val . ,(car case))
+ `(,(pcase--match val (pcase--macroexpand (car case)))
,(lambda (vars)
(unless (memq case used-cases)
;; Keep track of the cases that are used.
vars))))
cases))))
(dolist (case cases)
- (unless (or (memq case used-cases) (eq (car case) 'pcase--dontcare))
+ (unless (or (memq case used-cases)
+ (memq (car case) pcase--dontwarn-upats))
(message "Redundant pcase pattern: %S" (car case))))
(macroexp-let* defs main))))
+(defun pcase--macroexpand (pat)
+ "Expands all macro-patterns in PAT."
+ (let ((head (car-safe pat)))
+ (cond
+ ((null head)
+ (if (pcase--self-quoting-p pat) `',pat pat))
+ ((memq head '(pred guard quote)) pat)
+ ((memq head '(or and)) `(,head ,@(mapcar #'pcase--macroexpand (cdr pat))))
+ ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat)))
+ ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat))))
+ (t
+ (let* ((expander (get head 'pcase-macroexpander))
+ (npat (if expander (apply expander (cdr pat)))))
+ (if (null npat)
+ (error (if expander
+ "Unexpandable %s pattern: %S"
+ "Unknown %s pattern: %S")
+ head pat)
+ (pcase--macroexpand npat)))))))
+
+;;;###autoload
+(defmacro pcase-defmacro (name args &rest body)
+ "Define a new kind of pcase PATTERN, by macro expansion.
+Patterns of the form (NAME ...) will be expanded according
+to this macro."
+ (declare (indent 2) (debug defun) (doc-string 3))
+ ;; Add the function via `fsym', so that an autoload cookie placed
+ ;; on a pcase-defmacro will cause the macro to be loaded on demand.
+ (let ((fsym (intern (format "%s--pcase-macroexpander" name)))
+ (decl (assq 'declare body)))
+ (when decl (setq body (remove decl body)))
+ `(progn
+ (defun ,fsym ,args ,@body)
+ (put ',fsym 'edebug-form-spec ',(cadr (assq 'debug decl)))
+ (put ',name 'pcase-macroexpander #',fsym))))
+
+(defun pcase--match (val upat)
+ "Build a MATCH structure, hoisting all `or's and `and's outside."
+ (cond
+ ;; Hoist or/and patterns into or/and matches.
+ ((memq (car-safe upat) '(or and))
+ `(,(car upat)
+ ,@(mapcar (lambda (upat)
+ (pcase--match val upat))
+ (cdr upat))))
+ (t
+ `(match ,val . ,upat))))
+
(defun pcase-codegen (code vars)
;; Don't use let*, otherwise macroexp-let* may merge it with some surrounding
;; let* which might prevent the setcar/setcdr in pcase--expand's fancy
((eq then :pcase--dontcare) (debug) else) ;Can/should this ever happen?
(t (macroexp-if test then else))))
-(defun pcase--upat (qpattern)
- (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
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)
+ (match VAR . PAT)
(and MATCH ...)
(or MATCH ...)"
(when (setq branches (delq nil branches))
(numberp . stringp)
(numberp . byte-code-function-p)
(consp . arrayp)
+ (consp . atom)
(consp . vectorp)
(consp . stringp)
(consp . byte-code-function-p)
(defun pcase--split-match (sym splitter match)
(cond
- ((eq (car match) 'match)
+ ((eq (car-safe 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))
- (pcase--split-match sym splitter
- (cons (car pat)
- (mapcar (lambda (alt)
- `(match ,sym . ,alt))
- (cdr pat)))))
- (t (let ((res (funcall splitter (cddr match))))
- (cons (or (car res) match) (or (cdr res) match))))))))
- ((memq (car match) '(or and))
+ (let ((res (funcall splitter (cddr match))))
+ (cons (or (car res) match) (or (cdr res) match)))))
+ ((memq (car-safe match) '(or and))
(let ((then-alts '())
(else-alts '())
(neutral-elem (if (eq 'or (car match))
((null else-alts) neutral-elem)
((null (cdr else-alts)) (car else-alts))
(t (cons (car match) (nreverse else-alts)))))))
+ ((memq match '(:pcase--succeed :pcase--fail)) (cons match match))
(t (error "Uknown MATCH %s" match))))
(defun pcase--split-rest (sym splitter rest)
(push (cons (cdr split) code&vars) else-rest))))
(cons (nreverse then-rest) (nreverse else-rest))))
-(defun pcase--split-consp (syma symd pat)
- (cond
- ;; A QPattern for a cons, can only go the `then' side.
- ((and (eq (car-safe pat) '\`) (consp (cadr pat)))
- (let ((qpat (cadr pat)))
- (cons `(and (match ,syma . ,(pcase--upat (car qpat)))
- (match ,symd . ,(pcase--upat (cdr qpat))))
- :pcase--fail)))
- ;; A QPattern but not for a cons, can only go to the `else' side.
- ((eq (car-safe pat) '\`) '(:pcase--fail . nil))
- ((and (eq (car-safe pat) 'pred)
- (pcase--mutually-exclusive-p #'consp (cadr pat)))
- '(:pcase--fail . nil))))
-
(defun pcase--split-equal (elem pat)
(cond
;; The same match will give the same result.
- ((and (eq (car-safe pat) '\`) (equal (cadr pat) elem))
+ ((and (eq (car-safe pat) 'quote) (equal (cadr pat) elem))
'(:pcase--succeed . :pcase--fail))
;; A different match will fail if this one succeeds.
- ((and (eq (car-safe pat) '\`)
+ ((and (eq (car-safe pat) 'quote)
;; (or (integerp (cadr pat)) (symbolp (cadr pat))
;; (consp (cadr pat)))
)
((and (eq (car-safe pat) 'pred)
(symbolp (cadr pat))
(get (cadr pat) 'side-effect-free))
- (if (funcall (cadr pat) elem)
- '(:pcase--succeed . nil)
- '(:pcase--fail . nil)))))
+ (ignore-errors
+ (if (funcall (cadr pat) elem)
+ '(:pcase--succeed . nil)
+ '(:pcase--fail . nil))))))
(defun pcase--split-member (elems pat)
+ ;; FIXME: The new pred-based member code doesn't do these optimizations!
;; Based on pcase--split-equal.
(cond
;; The same match (or a match of membership in a superset) will
;; (???
;; '(:pcase--succeed . nil))
;; A match for one of the elements may succeed or fail.
- ((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
+ ((and (eq (car-safe pat) 'quote) (member (cadr pat) elems))
nil)
;; A different match will fail if this one succeeds.
- ((and (eq (car-safe pat) '\`)
+ ((and (eq (car-safe pat) 'quote)
;; (or (integerp (cadr pat)) (symbolp (cadr pat))
;; (consp (cadr pat)))
)
((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))
+ (ignore-errors
+ (let ((p (cadr pat)) (all t))
+ (dolist (elem elems)
+ (unless (funcall p elem) (setq all nil)))
+ all)))
'(:pcase--succeed . nil))))
(defun pcase--split-pred (vars upat pat)
((and (eq 'pred (car upat))
(let ((otherpred
(cond ((eq 'pred (car-safe pat)) (cadr pat))
- ((not (eq '\` (car-safe pat))) nil)
+ ((not (eq 'quote (car-safe pat))) nil)
((consp (cadr pat)) #'consp)
+ ((stringp (cadr pat)) #'stringp)
((vectorp (cadr pat)) #'vectorp)
((byte-code-function-p (cadr pat))
#'byte-code-function-p))))
(pcase--mutually-exclusive-p (cadr upat) otherpred)))
'(:pcase--fail . nil))
((and (eq 'pred (car upat))
- (eq '\` (car-safe pat))
+ (eq 'quote (car-safe pat))
(symbolp (cadr upat))
(or (symbolp (cadr pat)) (stringp (cadr pat)) (numberp (cadr pat)))
(get (cadr upat) 'side-effect-free)
res))
(defun pcase--self-quoting-p (upat)
- (or (keywordp upat) (numberp upat) (stringp upat)))
+ (or (keywordp upat) (integerp upat) (stringp upat)))
+
+(defun pcase--app-subst-match (match sym fun nsym)
+ (cond
+ ((eq (car-safe match) 'match)
+ (if (and (eq sym (cadr match))
+ (eq 'app (car-safe (cddr match)))
+ (equal fun (nth 1 (cddr match))))
+ (pcase--match nsym (nth 2 (cddr match)))
+ match))
+ ((memq (car-safe match) '(or and))
+ `(,(car match)
+ ,@(mapcar (lambda (match)
+ (pcase--app-subst-match match sym fun nsym))
+ (cdr match))))
+ ((memq match '(:pcase--succeed :pcase--fail)) match)
+ (t (error "Uknown MATCH %s" match))))
+
+(defun pcase--app-subst-rest (rest sym fun nsym)
+ (mapcar (lambda (branch)
+ `(,(pcase--app-subst-match (car branch) sym fun nsym)
+ ,@(cdr branch)))
+ rest))
(defsubst pcase--mark-used (sym)
;; Exceptionally, `sym' may be a constant expression rather than a symbol.
(if (symbolp sym) (put sym 'pcase-used t)))
+(defmacro pcase--flip (fun arg1 arg2)
+ "Helper function, used internally to avoid (funcall (lambda ...) ...)."
+ (declare (debug (sexp body)))
+ `(,fun ,arg2 ,arg1))
+
+(defun pcase--funcall (fun arg vars)
+ "Build a function call to FUN with arg ARG."
+ (if (symbolp fun)
+ `(,fun ,arg)
+ (let* (;; `vs' is an upper bound on the vars we need.
+ (vs (pcase--fgrep (mapcar #'car vars) fun))
+ (env (mapcar (lambda (var)
+ (list var (cdr (assq var vars))))
+ vs))
+ (call (progn
+ (when (memq arg vs)
+ ;; `arg' is shadowed by `env'.
+ (let ((newsym (make-symbol "x")))
+ (push (list newsym arg) env)
+ (setq arg newsym)))
+ (if (functionp fun)
+ `(funcall #',fun ,arg)
+ `(,@fun ,arg)))))
+ (if (null vs)
+ call
+ ;; Let's not replace `vars' in `fun' since it's
+ ;; too difficult to do it right, instead just
+ ;; let-bind `vars' around `fun'.
+ `(let* ,env ,call)))))
+
+(defun pcase--eval (exp vars)
+ "Build an expression that will evaluate EXP."
+ (let* ((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)))))
+
;; It's very tempting to use `pcase' below, tho obviously, it'd create
;; bootstrapping problems.
(defun pcase--u1 (matches code vars rest)
((eq 'or (caar matches))
(let* ((alts (cdar matches))
(var (if (eq (caar alts) 'match) (cadr (car alts))))
- (simples '()) (others '()))
+ (simples '()) (others '()) (memq-ok t))
(when var
(dolist (alt alts)
(if (and (eq (car alt) 'match) (eq var (cadr alt))
(let ((upat (cddr alt)))
- (and (eq (car-safe upat) '\`)
- (or (integerp (cadr upat)) (symbolp (cadr upat))
- (stringp (cadr upat))))))
- (push (cddr alt) simples)
+ (eq (car-safe upat) 'quote)))
+ (let ((val (cadr (cddr alt))))
+ (unless (or (integerp val) (symbolp val))
+ (setq memq-ok nil))
+ (push (cadr (cddr alt)) simples))
(push alt others))))
(cond
((null alts) (error "Please avoid it") (pcase--u rest))
+ ;; Yes, we can use `memq' (or `member')!
((> (length simples) 1)
- ;; De-hoist the `or' MATCH into an `or' pattern that will be
- ;; turned into a `memq' below.
- (pcase--u1 (cons `(match ,var or . ,(nreverse simples)) (cdr matches))
+ (pcase--u1 (cons `(match ,var
+ . (pred (pcase--flip
+ ,(if memq-ok #'memq #'member)
+ ',simples)))
+ (cdr matches))
code vars
(if (null others) rest
(cons (cons
(sym (car cdrpopmatches))
(upat (cdr cdrpopmatches)))
(cond
- ((memq upat '(t _)) (pcase--u1 matches code vars rest))
+ ((memq upat '(t _))
+ (let ((code (pcase--u1 matches code vars rest)))
+ (if (eq upat '_) code
+ (macroexp--warn-and-return
+ "Pattern t is deprecated. Use `_' instead"
+ code))))
((eq upat 'pcase--dontcare) :pcase--dontcare)
((memq (car-safe upat) '(guard pred))
(if (eq (car upat) 'pred) (pcase--mark-used sym))
sym (lambda (pat) (pcase--split-pred vars upat pat)) rest))
(then-rest (car splitrest))
(else-rest (cdr splitrest)))
- (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))
- (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)))
- (if (functionp exp)
- `(funcall #',exp ,sym)
- `(,@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* ,env ,call))))
+ (pcase--if (if (eq (car upat) 'pred)
+ (pcase--funcall (cadr upat) sym vars)
+ (pcase--eval (cadr upat) vars))
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
- ((pcase--self-quoting-p upat)
- (pcase--mark-used sym)
- (pcase--q1 sym upat matches code vars rest))
- ((symbolp upat)
+ ((and (symbolp upat) upat)
(pcase--mark-used sym)
(if (not (assq upat vars))
(pcase--u1 matches code (cons (cons upat sym) vars) rest)
;; (cons (cons (nth 1 upat) (nth 2 upat)) vars) rest)
(macroexp-let2
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)
+ (pcase--eval (nth 2 upat) vars)
+ (pcase--u1 (cons (pcase--match sym (nth 1 upat)) matches)
code vars rest)))
- ((eq (car-safe upat) '\`)
+ ((eq (car-safe upat) 'app)
+ ;; A upat of the form (app FUN PAT)
(pcase--mark-used sym)
- (pcase--q1 sym (cadr upat) matches code vars rest))
- ((eq (car-safe upat) 'or)
- (let ((all (> (length (cdr upat)) 1))
- (memq-fine t))
- (when all
- (dolist (alt (cdr upat))
- (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)))))
- (setq all nil))))
- (if all
- ;; Use memq for (or `a `b `c `d) rather than a big tree.
- (let* ((elems (mapcar (lambda (x) (if (consp x) (cadr x) x))
- (cdr upat)))
- (splitrest
- (pcase--split-rest
- sym (lambda (pat) (pcase--split-member elems pat)) rest))
- (then-rest (car splitrest))
- (else-rest (cdr splitrest)))
- (pcase--mark-used sym)
- (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)))))
- ((eq (car-safe upat) 'and)
- (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat))
- (cdr upat))
- matches)
- code vars rest))
+ (let* ((fun (nth 1 upat))
+ (nsym (make-symbol "x"))
+ (body
+ ;; We don't change `matches' to reuse the newly computed value,
+ ;; because we assume there shouldn't be such redundancy in there.
+ (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches)
+ code vars
+ (pcase--app-subst-rest rest sym fun nsym))))
+ (if (not (get nsym 'pcase-used))
+ body
+ (macroexp-let*
+ `((,nsym ,(pcase--funcall fun sym vars)))
+ body))))
+ ((eq (car-safe upat) 'quote)
+ (pcase--mark-used sym)
+ (let* ((val (cadr upat))
+ (splitrest (pcase--split-rest
+ sym (lambda (pat) (pcase--split-equal val pat)) rest))
+ (then-rest (car splitrest))
+ (else-rest (cdr splitrest)))
+ (pcase--if (cond
+ ((null val) `(null ,sym))
+ ((or (integerp val) (symbolp val))
+ (if (pcase--self-quoting-p val)
+ `(eq ,sym ,val)
+ `(eq ,sym ',val)))
+ (t `(equal ,sym ',val)))
+ (pcase--u1 matches code vars then-rest)
+ (pcase--u else-rest))))
((eq (car-safe upat) 'not)
;; FIXME: The implementation below is naive and results in
;; inefficient code.
(pcase--u rest))
vars
(list `((and . ,matches) ,code . ,vars))))
- (t (error "Unknown upattern `%s'" upat)))))
- (t (error "Incorrect MATCH %s" (car matches)))))
+ (t (error "Unknown pattern `%S'" upat)))))
+ (t (error "Incorrect MATCH %S" (car matches)))))
-(defun pcase--q1 (sym qpat matches code vars rest)
- "Return code that runs CODE if SYM matches QPAT and if MATCHES match.
-Otherwise, it defers to REST which is a list of branches of the form
-\(OTHER_MATCH OTHER-CODE . OTHER-VARS)."
+(def-edebug-spec
+ pcase-QPAT
+ ;; Cf. edebug spec for `backquote-form' in edebug.el.
+ (&or ("," pcase-PAT)
+ (pcase-QPAT [&rest [¬ ","] pcase-QPAT]
+ . [&or nil pcase-QPAT])
+ (vector &rest pcase-QPAT)
+ sexp))
+
+(pcase-defmacro \` (qpat)
+ "Backquote-style pcase patterns.
+QPAT can take the following forms:
+ (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.
+ ,PAT matches if the pcase pattern PAT matches.
+ ATOM matches if the object is `equal' to ATOM.
+ ATOM can be a symbol, an integer, or a string."
+ (declare (debug (pcase-QPAT)))
(cond
- ((eq (car-safe qpat) '\,) (error "Can't use `,UPATTERN"))
- ((floatp qpat) (error "Floating point patterns not supported"))
+ ((eq (car-safe qpat) '\,) (cadr qpat))
((vectorp qpat)
- ;; FIXME.
- (error "Vector QPatterns not implemented yet"))
+ `(and (pred vectorp)
+ (app length ,(length qpat))
+ ,@(let ((upats nil))
+ (dotimes (i (length qpat))
+ (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
+ upats))
+ (nreverse upats))))
((consp qpat)
- (let* ((syma (make-symbol "xcar"))
- (symd (make-symbol "xcdr"))
- (splitrest (pcase--split-rest
- sym
- (lambda (pat) (pcase--split-consp syma symd pat))
- 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.
- ;; FIXME: Some of those let bindings occur too early (they are used in
- ;; `then-body', but only within some sub-branch).
- (macroexp-let*
- `(,@(if (get syma 'pcase-used) `((,syma (car ,sym))))
- ,@(if (get symd 'pcase-used) `((,symd (cdr ,sym)))))
- then-body)
- (pcase--u else-rest))))
- ((or (integerp qpat) (symbolp qpat) (stringp qpat))
- (let* ((splitrest (pcase--split-rest
- sym (lambda (pat) (pcase--split-equal qpat pat)) rest))
- (then-rest (car splitrest))
- (else-rest (cdr splitrest)))
- (pcase--if (cond
- ((stringp qpat) `(equal ,sym ,qpat))
- ((null qpat) `(null ,sym))
- (t `(eq ,sym ',qpat)))
- (pcase--u1 matches code vars then-rest)
- (pcase--u else-rest))))
- (t (error "Unknown QPattern %s" qpat))))
+ `(and (pred consp)
+ (app car ,(list '\` (car qpat)))
+ (app cdr ,(list '\` (cdr qpat)))))
+ ((or (stringp qpat) (integerp qpat) (symbolp qpat)) `',qpat)
+ (t (error "Unknown QPAT: %S" qpat))))
(provide 'pcase)