From d56b1f9e7cee077011fa1256c2965c2984a17282 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 1 Mar 2021 14:07:05 -0500 Subject: * lisp/emacs-lisp/pcase.el (pcase--split-pred): Re-fix bug#14773 Adjust to calling convention of `macroexp--fgrep`. --- test/lisp/emacs-lisp/pcase-tests.el | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'test/lisp/emacs-lisp/pcase-tests.el') diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index e6f4c097504..14384112b34 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -75,6 +75,14 @@ (ert-deftest pcase-tests-vectors () (should (equal (pcase [1 2] (`[,x] 1) (`[,x ,y] (+ x y))) 3))) +(ert-deftest pcase-tests-bug14773 () + (let ((f (lambda (x) + (pcase 'dummy + ((and (let var x) (guard var)) 'left) + ((and (let var (not x)) (guard var)) 'right))))) + (should (equal (funcall f t) 'left)) + (should (equal (funcall f nil) 'right)))) + ;; Local Variables: ;; no-byte-compile: t ;; End: -- cgit v1.2.3 From 0d827c7f52b92aaffe751cf937427938f1ac67de Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 1 Mar 2021 15:35:51 -0500 Subject: * lisp/emacs-lisp/pcase.el: Fix bug#46786 Revert commit a218c9861573b5ec4979ff2662f5c0343397e3ff, but in order to avoid the spurious warnings that this commit tried to squash, keep track of the vars used during the match so as to add corresponding annotations to explicitly silence the spurious warnings. To do this, we change the VARS used in `pcase-u` (and throughout the pcase code): they used to hold elements of the form (NAME . VAL) and now they hold elements of the form (NAME VAL . USED). (pcase--expand): Bind all vars instead of only those found via fgrep. (pcase-codegen): Silence "unused var" warnings for those vars that have already been referenced during the match itself. (pcase--funcall, pcase--eval): Record the vars that are used. (pcase--u1): Record the vars that are used via non-linear patterns. * lisp/textmodes/mhtml-mode.el (mhtml-forward): * lisp/vc/diff-mode.el (diff-goto-source): Silence newly discovered warnings. * test/lisp/emacs-lisp/pcase-tests.el (pcase-tests-bug46786): New test. --- lisp/emacs-lisp/pcase.el | 60 ++++++++++++++++++++++--------------- lisp/textmodes/mhtml-mode.el | 2 +- lisp/vc/diff-mode.el | 2 +- test/lisp/emacs-lisp/pcase-tests.el | 7 +++++ 4 files changed, 45 insertions(+), 26 deletions(-) (limited to 'test/lisp/emacs-lisp/pcase-tests.el') diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index b1e1305edfe..0fa1b980a0f 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -328,8 +328,7 @@ of the elements of LIST is performed as if by `pcase-let'. (seen '()) (codegen (lambda (code vars) - (let ((vars (macroexp--fgrep vars code)) - (prev (assq code seen))) + (let ((prev (assq code seen))) (if (not prev) (let ((res (pcase-codegen code vars))) (push (list code vars res) seen) @@ -354,14 +353,14 @@ of the elements of LIST is performed as if by `pcase-let'. (push `(,bsym (lambda ,(mapcar #'car prevvars) ,@code)) defs) (setcar res 'funcall) - (setcdr res (cons bsym (mapcar #'cdr prevvars))) + (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)) - (cdr v))) + (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 @@ -383,9 +382,7 @@ of the elements of LIST is performed as if by `pcase-let'. (if (pcase--small-branch-p (cdr case)) ;; Don't bother sharing multiple ;; occurrences of this leaf since it's small. - (lambda (code vars) - (pcase-codegen code - (macroexp--fgrep vars code))) + #'pcase-codegen codegen) (cdr case) vars)))) @@ -452,10 +449,15 @@ for the result of evaluating EXP (first arg to `pcase'). ;; 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 vars - `(let ,(mapcar (lambda (b) (list (car b) (cdr b))) vars) - ,@code) - `(progn ,@code))) + (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)) @@ -497,11 +499,14 @@ for the result of evaluating EXP (first arg to `pcase'). "Expand matcher for rules BRANCHES. Each BRANCH has the form (MATCH CODE . VARS) where CODE is the code generator for that branch. -VARS is the set of vars already bound by earlier matches. MATCH is the pattern that needs to be matched, of the form: (match VAR . PAT) (and MATCH ...) - (or MATCH ...)" + (or MATCH ...) +VARS is the set of vars already bound by earlier matches. +It is a list of (NAME VAL . USED) where NAME is the variable's symbol, +VAL is the expression to which it should be bound and USED is a boolean +recording whether the var has been referenced by earlier parts of the match." (when (setq branches (delq nil branches)) (let* ((carbranch (car branches)) (match (car carbranch)) (cdarbranch (cdr carbranch)) @@ -748,8 +753,11 @@ A and B can be one of: ((symbolp fun) `(,fun ,arg)) ((eq 'not (car-safe fun)) `(not ,(pcase--funcall (cadr fun) arg vars))) (t - (let* (;; `env' is an upper bound on the bindings we need. - (env (mapcar (lambda (x) (list (car x) (cdr x))) + (let* (;; `env' is hopefully an upper bound on the bindings we need, + ;; FIXME: See bug#46786 for a counter example :-( + (env (mapcar (lambda (x) + (setcdr (cdr x) 'used) + (list (car x) (cadr x))) (macroexp--fgrep vars fun))) (call (progn (when (assq arg env) @@ -757,7 +765,7 @@ A and B can be one of: (let ((newsym (gensym "x"))) (push (list newsym arg) env) (setq arg newsym))) - (if (functionp fun) + (if (or (functionp fun) (not (consp fun))) `(funcall #',fun ,arg) `(,@fun ,arg))))) (if (null env) @@ -770,10 +778,12 @@ A and B can be one of: (defun pcase--eval (exp vars) "Build an expression that will evaluate EXP." (let* ((found (assq exp vars))) - (if found (cdr found) + (if found (progn (setcdr (cdr found) 'used) (cadr found)) (let* ((env (macroexp--fgrep vars exp))) (if env - (macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x))) + (macroexp-let* (mapcar (lambda (x) + (setcdr (cdr x) 'used) + (list (car x) (cadr x))) env) exp) exp))))) @@ -865,12 +875,14 @@ Otherwise, it defers to REST which is a list of branches of the form (pcase--u else-rest)))) ((and (symbolp upat) upat) (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 . (pred (eql ,(cdr (assq upat vars))))) - matches) - code vars rest))) + (let ((v (assq upat vars))) + (if (not v) + (pcase--u1 matches code (cons (list upat sym) vars) rest) + ;; Non-linear pattern. Turn it into an `eq' test. + (setq (cddr v) 'used) + (pcase--u1 (cons `(match ,sym . (pred (eql ,(cadr v)))) + matches) + code vars rest)))) ((eq (car-safe upat) 'app) ;; A upat of the form (app FUN PAT) (pcase--mark-used sym) diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el index 32542d0400f..25905385685 100644 --- a/lisp/textmodes/mhtml-mode.el +++ b/lisp/textmodes/mhtml-mode.el @@ -313,7 +313,7 @@ Prefix arg specifies how many times to move (default 1)." (interactive "P") (pcase (get-text-property (point) 'mhtml-submode) ('nil (sgml-skip-tag-forward arg)) - (submode (forward-sexp arg)))) + (_submode (forward-sexp arg)))) ;;;###autoload (define-derived-mode mhtml-mode html-mode diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 8bbab467af3..342b4cc32b1 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -2003,7 +2003,7 @@ revision of the file otherwise." (if event (posn-set-point (event-end event))) (let ((buffer (when event (current-buffer))) (reverse (not (save-excursion (beginning-of-line) (looking-at "[-<]"))))) - (pcase-let ((`(,buf ,line-offset ,pos ,src ,_dst ,switched) + (pcase-let ((`(,buf ,_line-offset ,pos ,src ,_dst ,_switched) (diff-find-source-location other-file reverse))) (pop-to-buffer buf) (goto-char (+ (car pos) (cdr src))) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 14384112b34..6ddeb7b622b 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -83,6 +83,13 @@ (should (equal (funcall f t) 'left)) (should (equal (funcall f nil) 'right)))) +(ert-deftest pcase-tests-bug46786 () + (let ((self 'outer)) + (should (equal (cl-macrolet ((show-self () `(list 'self self))) + (pcase-let ((`(,self ,self2) '(inner "2"))) + (show-self))) + '(self inner))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: -- cgit v1.2.3 From 165353674e5fe7109ba9cbf526de0333902b7851 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 1 Mar 2021 23:57:34 -0500 Subject: * 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(-) (limited to 'test/lisp/emacs-lisp/pcase-tests.el') 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. -- cgit v1.2.3