;;; pcase.el --- ML-style pattern-matching macro for Elisp -*- lexical-binding: t; coding: utf-8 -*-
-;; Copyright (C) 2010-2012 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:
;; 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.
+;; FIXME: Now that macroexpansion is also performed when loading an interpreted
+;; file, this is not a real problem any more.
(defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq))
;; (defconst pcase--memoize-1 (make-hash-table :test 'eq))
;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal))
-(defconst pcase--dontcare-upats '(t _ dontcare))
+(defconst pcase--dontcare-upats '(t _ pcase--dontcare))
(def-edebug-spec
pcase-UPAT
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.
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.
+ (FUN ARG1 .. ARGN) in which case it 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
(pcase--expand
(cadr binding)
`((,(car binding) ,(pcase--let* 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)))))))
+ ;; 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)))))))
;;;###autoload
(defmacro pcase-let* (bindings &rest body)
vars))))
cases))))
(dolist (case cases)
- (unless (or (memq case used-cases) (eq (car case) 'dontcare))
+ (unless (or (memq case used-cases) (eq (car case) 'pcase--dontcare))
(message "Redundant pcase pattern: %S" (car case))))
(macroexp-let* defs main))))
(symbolp . numberp)
(symbolp . consp)
(symbolp . arrayp)
+ (symbolp . vectorp)
(symbolp . stringp)
(symbolp . byte-code-function-p)
(integerp . consp)
(integerp . arrayp)
+ (integerp . vectorp)
(integerp . stringp)
(integerp . byte-code-function-p)
(numberp . consp)
(numberp . arrayp)
+ (numberp . vectorp)
(numberp . stringp)
(numberp . byte-code-function-p)
(consp . arrayp)
+ (consp . vectorp)
(consp . stringp)
(consp . byte-code-function-p)
- (arrayp . stringp)
(arrayp . byte-code-function-p)
+ (vectorp . byte-code-function-p)
+ (stringp . vectorp)
(stringp . byte-code-function-p)))
+(defun pcase--mutually-exclusive-p (pred1 pred2)
+ (or (member (cons pred1 pred2)
+ pcase-mutually-exclusive-predicates)
+ (member (cons pred2 pred1)
+ pcase-mutually-exclusive-predicates)))
+
(defun pcase--split-match (sym splitter match)
(cond
((eq (car match) 'match)
(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) '\`) (cons :pcase--fail nil))
+ ((eq (car-safe pat) '\`) '(: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))))
+ (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))
- (cons :pcase--succeed :pcase--fail))
+ '(:pcase--succeed . :pcase--fail))
;; A different match will fail if this one succeeds.
((and (eq (car-safe pat) '\`)
;; (or (integerp (cadr pat)) (symbolp (cadr pat))
;; (consp (cadr pat)))
)
- (cons :pcase--fail nil))
+ '(: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))))
+ (get (cadr pat) 'side-effect-free))
+ (if (funcall (cadr pat) elem)
+ '(:pcase--succeed . nil)
+ '(:pcase--fail . nil)))))
(defun pcase--split-member (elems pat)
;; Based on pcase--split-equal.
;; 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.
;; (???
- ;; (cons :pcase--succeed nil))
+ ;; '(:pcase--succeed . nil))
;; A match for one of the elements may succeed or fail.
((and (eq (car-safe pat) '\`) (member (cadr pat) elems))
nil)
;; (or (integerp (cadr pat)) (symbolp (cadr pat))
;; (consp (cadr pat)))
)
- (cons :pcase--fail nil))
+ '(:pcase--fail . nil))
((and (eq (car-safe pat) 'pred)
(symbolp (cadr pat))
(get (cadr pat) 'side-effect-free)
(dolist (elem elems)
(unless (funcall p elem) (setq all nil)))
all))
- (cons :pcase--succeed nil))))
+ '(:pcase--succeed . nil))))
-(defun pcase--split-pred (upat pat)
- ;; FIXME: For predicates like (pred (> a)), two such predicates may
- ;; actually refer to different variables `a'.
+(defun pcase--split-pred (vars upat pat)
(let (test)
(cond
- ((equal upat pat) (cons :pcase--succeed :pcase--fail))
+ ((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))
((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))
+ (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)))
+ '(:pcase--fail . nil))
((and (eq 'pred (car upat))
(eq '\` (car-safe pat))
(symbolp (cadr upat))
(ignore-errors
(setq test (list (funcall (cadr upat) (cadr pat))))))
(if (car test)
- (cons nil :pcase--fail)
- (cons :pcase--fail nil))))))
+ '(nil . :pcase--fail)
+ '(:pcase--fail . nil))))))
(defun pcase--fgrep (vars sexp)
"Check which of the symbols VARS appear in SEXP."
(and (memq sexp vars) (not (memq sexp res)) (push sexp res))
res))
+(defun pcase--self-quoting-p (upat)
+ (or (keywordp upat) (numberp upat) (stringp upat)))
+
+(defsubst pcase--mark-used (sym)
+ ;; Exceptionally, `sym' may be a constant expression rather than a symbol.
+ (if (symbolp sym) (put sym 'pcase-used t)))
+
;; It's very tempting to use `pcase' below, tho obviously, it'd create
;; bootstrapping problems.
(defun pcase--u1 (matches code vars rest)
(upat (cdr cdrpopmatches)))
(cond
((memq upat '(t _)) (pcase--u1 matches code vars rest))
- ((eq upat 'dontcare) :pcase--dontcare)
+ ((eq upat 'pcase--dontcare) :pcase--dontcare)
((memq (car-safe upat) '(guard pred))
- (if (eq (car upat) 'pred) (put sym 'pcase-used t))
+ (if (eq (car upat) 'pred) (pcase--mark-used sym))
(let* ((splitrest
(pcase--split-rest
- sym (lambda (pat) (pcase--split-pred upat pat)) rest))
+ 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)))
`(let* ,env ,call))))
(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)
- (put sym 'pcase-used t)
+ (pcase--mark-used sym)
(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 . ,(nth 1 upat)) matches)
code vars rest)))
((eq (car-safe upat) '\`)
- (put sym 'pcase-used t)
+ (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 (and (eq (car-safe alt) '\`)
- (or (symbolp (cadr alt)) (integerp (cadr alt))
- (setq memq-fine nil)
- (stringp (cadr alt))))
+ (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 'cadr (cdr upat)))
+ (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)))
- (put sym 'pcase-used t)
+ (pcase--mark-used sym)
(pcase--if `(,(if memq-fine #'memq #'member) ,sym ',elems)
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest)))
HCoop / bpt / emacs.git / blobdiff