;;; 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-2014 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:
(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))
+ (ignore-errors
+ (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)
- (let ((p (cadr pat)) (all t))
- (dolist (elem elems)
- (unless (funcall p elem) (setq all nil)))
- all))
- (cons :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'.
+ (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)
(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."
(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)
((memq upat '(t _)) (pcase--u1 matches code vars rest))
((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)))
(pcase--u1 matches code vars then-rest)
(pcase--u else-rest))))
((pcase--self-quoting-p upat)
- (put sym 'pcase-used t)
+ (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 (or (pcase--self-quoting-p alt)
- (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.
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)))
;; `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)))))
+ ,@(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)))
+ (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))