From 1a6255532e14c4341e93b7e576c47bcec68c3239 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 22 Sep 2014 12:22:50 -0400 Subject: [PATCH] * lisp/emacs-lisp/pcase.el (pcase--match): New smart-constructor function. (pcase--expand pcase--q1, pcase--app-subst-match): Use it. (pcase--macroexpand): Handle self-quoting patterns here, expand them to quote patterns. (pcase--split-match): Don't hoist or/and here any more. (pcase--split-equal): Optimize quote patterns as well as ` patterns. (pcase--flip): New helper macro. (pcase--u1): Optimize the memq case directly. Don't handle neither self-quoting nor and/or patterns any more. --- lisp/ChangeLog | 10 +++ lisp/emacs-lisp/pcase.el | 126 +++++++++++++++------------------- test/automated/pcase-tests.el | 34 ++++++++- 3 files changed, 99 insertions(+), 71 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 32843569eda..ea09a9afa7b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,15 @@ 2014-09-22 Stefan Monnier + * emacs-lisp/pcase.el (pcase--match): New smart-constructor function. + (pcase--expand pcase--q1, pcase--app-subst-match): Use it. + (pcase--macroexpand): Handle self-quoting patterns here, expand them to + quote patterns. + (pcase--split-match): Don't hoist or/and here any more. + (pcase--split-equal): Optimize quote patterns as well as ` patterns. + (pcase--flip): New helper macro. + (pcase--u1): Optimize the memq case directly. + Don't handle neither self-quoting nor and/or patterns any more. + * emacs-lisp/pcase.el (pcase-defmacro): New macro. (pcase--macroexpand): New function. (pcase--expand): Use it. diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 2d5f19fe5f7..cfbe63e073f 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -284,7 +284,7 @@ of the form (UPAT EXP)." (main (pcase--u (mapcar (lambda (case) - `((match ,val . ,(pcase--macroexpand (car case))) + `(,(pcase--match val (pcase--macroexpand (car case))) ,(lambda (vars) (unless (memq case used-cases) ;; Keep track of the cases that are used. @@ -307,7 +307,9 @@ of the form (UPAT EXP)." "Expands all macro-patterns in PAT." (let ((head (car-safe pat))) (cond - ((memq head '(nil pred guard quote)) pat) + ((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)))) @@ -328,6 +330,18 @@ of the form (UPAT EXP)." `(put ',name 'pcase-macroexpander (lambda ,args ,@body))) +(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 @@ -431,17 +445,8 @@ MATCH is the pattern that needs to be matched, of the form: ((eq (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)) - (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)))))))) + (let ((res (funcall splitter (cddr match)))) + (cons (or (car res) match) (or (cdr res) match))))) ((memq (car match) '(or and)) (let ((then-alts '()) (else-alts '()) @@ -483,8 +488,8 @@ MATCH is the pattern that needs to be matched, of the form: ;; 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)))) + (cons `(and ,(pcase--match syma (pcase--upat (car qpat))) + ,(pcase--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)) @@ -513,10 +518,10 @@ MATCH is the pattern that needs to be matched, of the form: (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 (memq (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 (memq (car-safe pat) '(quote \`)) ;; (or (integerp (cadr pat)) (symbolp (cadr pat)) ;; (consp (cadr pat))) ) @@ -607,7 +612,7 @@ MATCH is the pattern that needs to be matched, of the form: (if (and (eq sym (cadr match)) (eq 'app (car-safe (cddr match))) (equal fun (nth 1 (cddr match)))) - `(match ,nsym ,@(nth 2 (cddr match))) + (pcase--match nsym (nth 2 (cddr match))) match)) ((memq (car match) '(or and)) `(,(car match) @@ -626,6 +631,11 @@ MATCH is the pattern that needs to be matched, of the form: ;; 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)) + ;; It's very tempting to use `pcase' below, tho obviously, it'd create ;; bootstrapping problems. (defun pcase--u1 (matches code vars rest) @@ -647,22 +657,26 @@ Otherwise, it defers to REST which is a list of branches of the form ((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 @@ -722,9 +736,6 @@ Otherwise, it defers to REST which is a list of branches of the form `(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) (pcase--mark-used sym) (if (not (assq upat vars)) @@ -746,7 +757,7 @@ Otherwise, it defers to REST which is a list of branches of the form (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--u1 (cons (pcase--match sym (nth 1 upat)) matches) code vars rest))) ((eq (car-safe upat) 'app) ;; A upat of the form (app FUN UPAT) @@ -763,7 +774,7 @@ Otherwise, it defers to REST which is a list of branches of the form (if env (macroexp-let* env call) call))) ;; 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 `(match ,nsym ,@(nth 2 upat)) matches) + (pcase--u1 (cons (pcase--match nsym (nth 2 upat)) matches) code vars (pcase--app-subst-rest rest sym fun nsym))))) ((eq (car-safe upat) '\`) @@ -777,46 +788,20 @@ Otherwise, it defers to REST which is a list of branches of the form (else-rest (cdr splitrest))) (pcase--if (cond ((null val) `(null ,sym)) - ((or (integerp val) (symbolp val)) - `(equal ,sym ,val)) + ((or (integerp val) (symbolp val)) `(eq ,sym ,val)) (t `(equal ,sym ',val))) (pcase--u1 matches code vars then-rest) (pcase--u else-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))))) + (error "Should have been hoisted already: %S" upat) + (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) + (error "Should have been hoisted already: %S" upat) (pcase--u1 (append (mapcar (lambda (upat) `(match ,sym ,@upat)) (cdr upat)) matches) @@ -864,8 +849,9 @@ Otherwise, it defers to REST which is a list of branches of the form (else-rest (cdr splitrest)) (then-body (pcase--u1 `(,@(mapcar (lambda (s) - `(match ,(car s) . - ,(pcase--upat (aref qpat (cdr s))))) + (pcase--match + (car s) + (pcase--upat (aref qpat (cdr s))))) syms) ,@matches) code vars then-rest))) @@ -886,8 +872,8 @@ Otherwise, it defers to REST which is a list of branches of the form 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))) + (then-body (pcase--u1 `(,(pcase--match syma (pcase--upat (car qpat))) + ,(pcase--match symd (pcase--upat (cdr qpat))) ,@matches) code vars then-rest))) (pcase--if diff --git a/test/automated/pcase-tests.el b/test/automated/pcase-tests.el index c51cf8d9573..7e3c40235e6 100644 --- a/test/automated/pcase-tests.el +++ b/test/automated/pcase-tests.el @@ -22,11 +22,43 @@ ;;; Code: (require 'ert) +(require 'cl-lib) -(ert-deftest pcase-tests-behavior () +(ert-deftest pcase-tests-base () "Test pcase code." (should (equal (pcase '(1 . 2) ((app car '2) 6) ((app car '1) 5)) 5))) +(pcase-defmacro pcase-tests-plus (pat n) + `(app (lambda (v) (- v ,n)) ,pat)) + +(ert-deftest pcase-tests-macro () + (should (equal (pcase 5 ((pcase-tests-plus x 3) x)) 2))) + +(defun pcase-tests-grep (fname exp) + (when (consp exp) + (or (eq fname (car exp)) + (cl-some (lambda (exp) (pcase-tests-grep fname exp)) (cdr exp))))) + +(ert-deftest pcase-tests-tests () + (should (pcase-tests-grep 'memq '(or (+ 2 3) (memq x y)))) + (should-not (pcase-tests-grep 'memq '(or (+ 2 3) (- x y))))) + +(ert-deftest pcase-tests-member () + (should (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or 1 2 3) body))))) + (should (pcase-tests-grep + 'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body))))) + (should-not (pcase-tests-grep + 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body))))) + (let ((exp (macroexpand-all + '(pcase x + ("a" body1) + (2 body2) + ((or "a" 2 3) body))))) + (should-not (pcase-tests-grep 'memq exp)) + (should-not (pcase-tests-grep 'member exp)))) + + ;; Local Variables: ;; no-byte-compile: t ;; End: -- 2.39.5