Skip to content

Commit

Permalink
* lisp/emacs-lisp/pcase.el: Bind all the vars in or patterns
Browse files Browse the repository at this point in the history 
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.
  • Loading branch information
@monnier
monnier committed Mar 2, 2021
1 parent bac0089 commit 1653536
Show file tree
Hide file tree
Showing 4 changed files with 86 additions and 86 deletions.
12 changes: 4 additions & 8 deletions doc/lispref/control.texi
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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}
Expand Down
5 changes: 5 additions & 0 deletions etc/NEWS
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
141 changes: 67 additions & 74 deletions lisp/emacs-lisp/pcase.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))))
Expand Down Expand Up @@ -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)))
Expand Down
14 changes: 10 additions & 4 deletions test/lisp/emacs-lisp/pcase-tests.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.

0 comments on commit 1653536

Please sign in to comment.