From 165353674e5fe7109ba9cbf526de0333902b7851 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 1 Mar 2021 23:57:34 -0500 Subject: [PATCH] * lisp/emacs-lisp/pcase.el: Bind all the vars in `or` patterns Improve the handling of `or` patterns where not all sub-patterns bind the same set of variables. This used to be "unsupported" and behaved in somewhat unpredictable ways. (pcase--expand): Rewrite. (pcase-codegen): Delete. * doc/lispref/control.texi (pcase Macro): Adjust accordingly. Also remove the warning about "at least two" sub patterns. These work fine, AFAICT, and if not we should fix it. * test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-or-vars): New test. --- doc/lispref/control.texi | 12 +-- etc/NEWS | 5 + lisp/emacs-lisp/pcase.el | 141 +++++++++++++--------------- test/lisp/emacs-lisp/pcase-tests.el | 14 ++- 4 files changed, 86 insertions(+), 86 deletions(-) diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 80e9eb7dd8e..3388102f694 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -617,17 +617,13 @@ match, @code{and} matches. @item (or @var{pattern1} @var{pattern2}@dots{}) Attempts to match @var{pattern1}, @var{pattern2}, @dots{}, in order, until one of them succeeds. In that case, @code{or} likewise matches, -and the rest of the sub-patterns are not tested. (Note that there -must be at least two sub-patterns. -Simply @w{@code{(or @var{pattern1})}} signals error.) -@c Issue: Is this correct and intended? -@c Are there exceptions, qualifications? -@c (Btw, ``Please avoid it'' is a poor error message.) +and the rest of the sub-patterns are not tested. To present a consistent environment (@pxref{Intro Eval}) to @var{body-forms} (thus avoiding an evaluation error on match), -if any of the sub-patterns let-binds a set of symbols, -they @emph{must} all bind the same set of symbols. +the set of variables bound by the pattern is the union of the +variables bound by each sub-pattern. If a variable is not bound by +the sub-pattern that matched, then it is bound to @code{nil}. @ifnottex @anchor{rx in pcase} diff --git a/etc/NEWS b/etc/NEWS index d01b532193d..73f136cfa7a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -387,6 +387,11 @@ in text mode. The cursor still only actually blinks in GUI frames. *** New macro 'bindat-spec' to define specs, with Edebug support ** pcase ++++ +*** The 'or' pattern now binds the union of the vars of its sub-patterns +If a variable is not bound by the subpattern that matched, it gets bound +to nil. This was already sometimes the case, but it is now guaranteed. + +++ *** The 'pred' pattern can now take the form '(pred (not FUN))'. This is like '(pred (lambda (x) (not (FUN x))))' but results diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 0fa1b980a0f..c565687896a 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -326,69 +326,76 @@ of the elements of LIST is performed as if by `pcase-let'. (macroexp-let2 macroexp-copyable-p val exp (let* ((defs ()) (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. - (let* ((code (car prev)) (cdrprev (cdr prev)) - (prevvars (car cdrprev)) (cddrprev (cdr cdrprev)) - (res (car cddrprev))) - (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 #'cadr 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)) - (cadr v))) - prevvars))) - ;; If some of `vars' were not found in `prevvars', that's - ;; OK it just means those vars aren't present in all - ;; branches, so they can be used within the pattern - ;; (e.g. by a `guard/let/pred') but not in the branch. - ;; FIXME: But if some of `prevvars' are not in `vars' we - ;; should remove them from `prevvars'! - `(funcall ,res ,@args))))))) - (used-cases ()) (main (pcase--u - (mapcar (lambda (case) - `(,(pcase--match val (pcase--macroexpand (car case))) - ,(lambda (vars) - (unless (memq case used-cases) - ;; Keep track of the cases that are used. - (push case used-cases)) - (funcall - (if (pcase--small-branch-p (cdr case)) - ;; Don't bother sharing multiple - ;; occurrences of this leaf since it's small. - #'pcase-codegen - codegen) - (cdr case) - vars)))) - cases)))) + (mapcar + (lambda (case) + `(,(pcase--match val (pcase--macroexpand (car case))) + ,(lambda (vars) + (let ((prev (assq case seen)) + (code (cdr case))) + (unless prev + ;; Keep track of the cases that are used. + (push (setq prev (list case)) seen)) + (if (member code '(nil (nil))) nil + ;; Put `code' in the cdr just so that not all + ;; branches look identical (to avoid things like + ;; `macroexp--if' optimizing them too optimistically). + (let ((ph (list 'pcase--placeholder code))) + (setcdr prev (cons (cons vars ph) (cdr prev))) + ph)))))) + cases)))) + ;; Take care of the place holders now. + (dolist (branch seen) + (let ((code (cdar branch)) + (uses (cdr branch))) + ;; Find all the vars that are in scope (the union of the + ;; vars provided in each use case). + (let* ((allvarinfo '()) + (_ (dolist (use uses) + (dolist (v (car use)) + (let ((vi (assq (car v) allvarinfo))) + (if vi + (if (cddr v) (setcdr vi 'used)) + (push (cons (car v) (cddr v)) allvarinfo)))))) + (allvars (mapcar #'car allvarinfo)) + (ignores (mapcar (lambda (vi) (when (cdr vi) `(ignore ,(car vi)))) + allvarinfo))) + ;; 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. + (if (or (null (cdr uses)) (pcase--small-branch-p code)) + (dolist (use uses) + (let ((vars (car use)) + (placeholder (cdr use))) + ;; (cl-assert (eq (car placeholder) 'pcase--placeholder)) + (setcar placeholder 'let) + (setcdr placeholder + `(,(mapcar (lambda (v) (list v (cadr (assq v vars)))) + allvars) + ;; Try and silence some of the most common + ;; spurious "unused var" warnings. + ,@ignores + ,@code)))) + ;; Several occurrence of this non-small branch in the output. + (let ((bsym + (make-symbol (format "pcase-%d" (length defs))))) + (push `(,bsym (lambda ,allvars ,@ignores ,@code)) defs) + (dolist (use uses) + (let ((vars (car use)) + (placeholder (cdr use))) + ;; (cl-assert (eq (car placeholder) 'pcase--placeholder)) + (setcar placeholder 'funcall) + (setcdr placeholder + `(,bsym + ,@(mapcar (lambda (v) (cadr (assq v vars))) + allvars)))))))))) (dolist (case cases) - (unless (or (memq case used-cases) + (unless (or (assq case seen) (memq (car case) pcase--dontwarn-upats)) (message "pcase pattern %S shadowed by previous pcase pattern" (car case)))) @@ -445,20 +452,6 @@ for the result of evaluating EXP (first arg to `pcase'). (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 - ;; codegen from later metamorphosing this let into a funcall. - (if (null vars) - `(progn ,@code) - `(let ,(mapcar (lambda (b) (list (car b) (cadr b))) vars) - ;; Try and silence some of the most common spurious "unused - ;; var" warnings. - ,@(delq nil (mapcar (lambda (var) - (if (cddr var) `(ignore ,(car var)))) - vars)) - ,@code))) - (defun pcase--small-branch-p (code) (and (= 1 (length code)) (or (not (consp (car code))) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 6ddeb7b622b..2120139ec18 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -85,13 +85,19 @@ (ert-deftest pcase-tests-bug46786 () (let ((self 'outer)) + (ignore self) (should (equal (cl-macrolet ((show-self () `(list 'self self))) - (pcase-let ((`(,self ,self2) '(inner "2"))) + (pcase-let ((`(,self ,_self2) '(inner "2"))) (show-self))) '(self inner))))) -;; Local Variables: -;; no-byte-compile: t -;; End: +(ert-deftest pcase-tests-or-vars () + (let ((f (lambda (v) + (pcase v + ((or (and 'b1 (let x1 4) (let x2 5)) + (and 'b2 (let y1 8) (let y2 9))) + (list x1 x2 y1 y2)))))) + (should (equal (funcall f 'b1) '(4 5 nil nil))) + (should (equal (funcall f 'b2) '(nil nil 8 9))))) ;;; pcase-tests.el ends here. -- 2.39.2