master 1653536: * lisp/emacs-lisp/pcase.el: Bind all the vars in `or` patterns

[Stefan Monnier]

branch: master
commit 165353674e5fe7109ba9cbf526de0333902b7851
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * 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 80e9eb7..3388102 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 d01b532..73f136c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -388,6 +388,11 @@ in text mode.  The cursor still only actually blinks in 
GUI frames.
 ** 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
 in better code.
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 0fa1b98..c565687 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 6ddeb7b..2120139 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.