From 0057294b2ad6cdd2802e1b290a190fa42e723fb8 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Jan 2021 20:15:17 +0200 Subject: Fix two tests * test/lisp/progmodes/elisp-mode-tests.el (xref-elisp-test-run): Make sure file names can be compared as strings, by running them through 'file-truename'. Reported by Vin Shelton . * test/lisp/emacs-lisp/bytecomp-tests.el ("warn-obsolete-hook.el") ("warn-obsolete-variable.el"): Use [^z-a] to match a newline as well. Reported by Vin Shelton . --- test/lisp/emacs-lisp/bytecomp-tests.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a07af188fac..263736af4ed 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -617,13 +617,13 @@ Subtests signal errors if something goes wrong." (make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99") (bytecomp--define-warning-file-test "warn-obsolete-hook.el" - "bytecomp--tests-obs.*obsolete.*99.99") + "bytecomp--tests-obs.*obsolete[^z-a]*99.99") (bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el" "foo-obs.*obsolete.*99.99" t) (bytecomp--define-warning-file-test "warn-obsolete-variable.el" - "bytecomp--tests-obs.*obsolete.*99.99") + "bytecomp--tests-obs.*obsolete[^z-a]*99.99") (bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el" "bytecomp--tests-obs.*obsolete.*99.99" t) -- cgit v1.2.3 From 0ab56a4e935b3aa759229923804ba33c841f425c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 16 Jan 2021 10:15:47 -0500 Subject: * lisp/emacs-lisp/pcase.el: Add support for `not` to `pred` (pcase--split-pred, pcase--funcall): Adjust for `not`. (pcase--get-macroexpander): New function. (pcase--edebug-match-macro, pcase--make-docstring) (pcase--macroexpand): Use it. * lisp/emacs-lisp/radix-tree.el (radix-tree-leaf): Use it! * doc/lispref/control.texi (The @code{pcase} macro): Document it. * lisp/emacs-lisp/ert.el (ert--explain-equal-rec): Remove redundant test. --- doc/lispref/control.texi | 5 ++-- etc/NEWS | 6 +++++ lisp/emacs-lisp/ert.el | 4 ++-- lisp/emacs-lisp/pcase.el | 46 +++++++++++++++++++++++++++++-------- lisp/emacs-lisp/radix-tree.el | 7 +++--- test/lisp/emacs-lisp/pcase-tests.el | 4 ++++ 6 files changed, 56 insertions(+), 16 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi index 55bcddb31aa..80e9eb7dd8e 100644 --- a/doc/lispref/control.texi +++ b/doc/lispref/control.texi @@ -557,8 +557,9 @@ Likewise, it makes no sense to bind keyword symbols @item (pred @var{function}) Matches if the predicate @var{function} returns non-@code{nil} -when called on @var{expval}. -the predicate @var{function} can have one of the following forms: +when called on @var{expval}. The test can be negated with the syntax +@code{(pred (not @var{function}))}. +The predicate @var{function} can have one of the following forms: @table @asis @item function name (a symbol) diff --git a/etc/NEWS b/etc/NEWS index fc7dcbcf4c6..359d308bf19 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -326,6 +326,12 @@ the buffer cycles the whole buffer between "only top-level headings", * Changes in Specialized Modes and Packages in Emacs 28.1 +** pcase ++++ +*** 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. + +++ ** profiler.el The results displayed by 'profiler-report' now have the usage figures diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 58517549454..fdbf95319ff 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -487,7 +487,7 @@ Errors during evaluation are caught and handled like nil." Returns nil if they are." (if (not (eq (type-of a) (type-of b))) `(different-types ,a ,b) - (pcase-exhaustive a + (pcase a ((pred consp) (let ((a-length (proper-list-p a)) (b-length (proper-list-p b))) @@ -538,7 +538,7 @@ Returns nil if they are." for xi = (ert--explain-equal-rec ai bi) do (when xi (cl-return `(array-elt ,i ,xi))) finally (cl-assert (equal a b) t)))) - ((pred atom) + (_ (if (not (equal a b)) (if (and (symbolp a) (symbolp b) (string= a b)) `(different-symbols-with-the-same-name ,a ,b) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 72ea1ba0188..bfd577c5d14 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -39,10 +39,10 @@ ;; - along these lines, provide patterns to match CL structs. ;; - provide something like (setq VAR) so a var can be set rather than ;; let-bound. -;; - provide a way to fallthrough to subsequent cases (not sure what I meant by -;; this :-() +;; - provide a way to fallthrough to subsequent cases +;; (e.g. Like Racket's (=> ID). ;; - try and be more clever to reduce the size of the decision tree, and -;; to reduce the number of leaves that need to be turned into function: +;; to reduce the number of leaves that need to be turned into functions: ;; - first, do the tests shared by all remaining branches (it will have ;; to be performed anyway, so better do it first so it's shared). ;; - then choose the test that discriminates more (?). @@ -97,11 +97,15 @@ (declare-function get-edebug-spec "edebug" (symbol)) (declare-function edebug-match "edebug" (cursor specs)) +(defun pcase--get-macroexpander (s) + "Return the macroexpander for pcase pattern head S, or nil" + (get s 'pcase-macroexpander)) + (defun pcase--edebug-match-macro (cursor) (let (specs) (mapatoms (lambda (s) - (let ((m (get s 'pcase-macroexpander))) + (let ((m (pcase--get-macroexpander s))) (when (and m (get-edebug-spec m)) (push (cons (symbol-name s) (get-edebug-spec m)) specs))))) @@ -128,6 +132,7 @@ PATTERN matches. PATTERN can take one of the forms: If a SYMBOL is used twice in the same pattern the second occurrence becomes an `eq'uality test. (pred FUN) matches if FUN called on EXPVAL returns non-nil. + (pred (not FUN)) matches if FUN called on EXPVAL returns nil. (app FUN PAT) matches if FUN called on EXPVAL matches PAT. (guard BOOLEXP) matches if BOOLEXP evaluates to non-nil. (let PAT EXPR) matches if EXPR matches PAT. @@ -193,7 +198,7 @@ Emacs Lisp manual for more information and examples." (let (more) ;; Collect all the extensions. (mapatoms (lambda (symbol) - (let ((me (get symbol 'pcase-macroexpander))) + (let ((me (pcase--get-macroexpander symbol))) (when me (push (cons symbol me) more))))) @@ -424,7 +429,7 @@ of the elements of LIST is performed as if by `pcase-let'. ((eq head 'let) `(let ,(pcase--macroexpand (cadr pat)) ,@(cddr pat))) ((eq head 'app) `(app ,(nth 1 pat) ,(pcase--macroexpand (nth 2 pat)))) (t - (let* ((expander (get head 'pcase-macroexpander)) + (let* ((expander (pcase--get-macroexpander head)) (npat (if expander (apply expander (cdr pat))))) (if (null npat) (error (if expander @@ -658,6 +663,14 @@ MATCH is the pattern that needs to be matched, of the form: '(:pcase--succeed . nil)))) (defun pcase--split-pred (vars upat pat) + "Indicate the overlap or mutual-exclusion between UPAT and PAT. +More specifically retuns a pair (A . B) where A indicates whether PAT +can match when UPAT has matched, and B does the same for the case +where UPAT failed to match. +A and B can be one of: +- nil if we don't know +- `:pcase--fail' if UPAT match's result implies that PAT can't match +- `:pcase--succeed' if UPAT match's result implies that PAT matches" (let (test) (cond ((and (equal upat pat) @@ -670,6 +683,19 @@ MATCH is the pattern that needs to be matched, of the form: ;; and catch at least the easy cases such as (bug#14773). (not (macroexp--fgrep (mapcar #'car vars) (cadr upat))))) '(:pcase--succeed . :pcase--fail)) + ;; In case UPAT is of the form (pred (not PRED)) + ((and (eq 'pred (car upat)) (eq 'not (car-safe (cadr upat)))) + (let* ((test (cadr (cadr upat))) + (res (pcase--split-pred vars `(pred ,test) pat))) + (cons (cdr res) (car res)))) + ;; In case PAT is of the form (pred (not PRED)) + ((and (eq 'pred (car-safe pat)) (eq 'not (car-safe (cadr pat)))) + (let* ((test (cadr (cadr pat))) + (res (pcase--split-pred vars upat `(pred ,test))) + (reverse (lambda (x) (cond ((eq x :pcase--succeed) :pcase--fail) + ((eq x :pcase--fail) :pcase--succeed))))) + (cons (funcall reverse (car res)) + (funcall reverse (cdr res))))) ((and (eq 'pred (car upat)) (let ((otherpred (cond ((eq 'pred (car-safe pat)) (cadr pat)) @@ -728,8 +754,10 @@ MATCH is the pattern that needs to be matched, of the form: (defun pcase--funcall (fun arg vars) "Build a function call to FUN with arg ARG." - (if (symbolp fun) - `(,fun ,arg) + (cond + ((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))) (macroexp--fgrep vars fun))) @@ -747,7 +775,7 @@ MATCH is the pattern that needs to be matched, of the form: ;; Let's not replace `vars' in `fun' since it's ;; too difficult to do it right, instead just ;; let-bind `vars' around `fun'. - `(let* ,env ,call))))) + `(let* ,env ,call)))))) (defun pcase--eval (exp vars) "Build an expression that will evaluate EXP." diff --git a/lisp/emacs-lisp/radix-tree.el b/lisp/emacs-lisp/radix-tree.el index 6a483a6d498..0905ac608bb 100644 --- a/lisp/emacs-lisp/radix-tree.el +++ b/lisp/emacs-lisp/radix-tree.el @@ -198,9 +198,10 @@ If not found, return nil." (pcase-defmacro radix-tree-leaf (vpat) "Pattern which matches a radix-tree leaf. The pattern VPAT is matched against the leaf's carried value." - ;; FIXME: We'd like to use a negative pattern (not consp), but pcase - ;; doesn't support it. Using `atom' works but generates sub-optimal code. - `(or `(t . ,,vpat) (and (pred atom) ,vpat)))) + ;; We used to use `(pred atom)', but `pcase' doesn't understand that + ;; `atom' is equivalent to the negation of `consp' and hence generates + ;; suboptimal code. + `(or `(t . ,,vpat) (and (pred (not consp)) ,vpat)))) (defun radix-tree-iter-subtrees (tree fun) "Apply FUN to every immediate subtree of radix TREE. diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 1b06c6e7543..e6f4c097504 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -32,6 +32,10 @@ (should (equal (pcase '(2 . 3) ;bug#18554 (`(,hd . ,(and (pred atom) tl)) (list hd tl)) ((pred consp) nil)) + '(2 3))) + (should (equal (pcase '(2 . 3) + (`(,hd . ,(and (pred (not consp)) tl)) (list hd tl)) + ((pred consp) nil)) '(2 3)))) (pcase-defmacro pcase-tests-plus (pat n) -- cgit v1.2.3 From b41b4add7bc2485fadc6ff3a890efbd1307b2351 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 21 Jan 2021 13:15:05 -0500 Subject: Fix spurious "Lexical argument shadows the dynamic variable" due to inlining Before this patch doing: rm lisp/calendar/calendar.elc make lisp/calendar/cal-hebrew.elc would spew out lots of spurious such warnings about a `date` argument, pointing to code which has no `date` argument in sight. This was because that code had calls to inlinable functions (taking a `date` argument) defined in `calendar.el`, and while `date` is a normal lexical var at the site of those functions' definitions, it was declared as dynbound at the call site. * lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand): Don't impose our local context onto the inlined function. * test/lisp/emacs-lisp/bytecomp-tests.el: Add matching test. --- lisp/emacs-lisp/byte-opt.el | 6 ++++-- .../lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el | 6 ++++++ .../bytecomp-resources/nowarn-inline-after-defvar.el | 17 +++++++++++++++++ test/lisp/emacs-lisp/bytecomp-tests.el | 4 ++++ 4 files changed, 31 insertions(+), 2 deletions(-) create mode 100644 test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el create mode 100644 test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el (limited to 'test/lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index cfa407019a7..66a117fccc8 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -284,8 +284,10 @@ ;; If `fn' is from the same file, it has already ;; been preprocessed! `(function ,fn) - (byte-compile-preprocess - (byte-compile--reify-function fn))))) + ;; Try and process it "in its original environment". + (let ((byte-compile-bound-variables nil)) + (byte-compile-preprocess + (byte-compile--reify-function fn)))))) (if (eq (car-safe newfn) 'function) (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form))) ;; This can happen because of macroexp-warn-and-return &co. diff --git a/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el new file mode 100644 index 00000000000..47481574ea8 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el @@ -0,0 +1,6 @@ +;; -*- lexical-binding: t; -*- + +(defsubst foo-inlineable (foo-var) + (+ foo-var 2)) + +(provide 'foo-inlinable) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el new file mode 100644 index 00000000000..5582b2ab0ea --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el @@ -0,0 +1,17 @@ +;; -*- lexical-binding: t; -*- + +;; In this test, we try and make sure that inlined functions's code isn't +;; mistakenly re-interpreted in the caller's context: we import an +;; inlinable function from another file where `foo-var' is a normal +;; lexical variable, and then call(inline) it in a function where +;; `foo-var' is a dynamically-scoped variable. + +(require 'foo-inlinable + (expand-file-name "foo-inlinable.el" + (file-name-directory + (or byte-compile-current-file load-file-name)))) + +(defvar foo-var) + +(defun foo-fun () + (+ (foo-inlineable 5) 1)) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 263736af4ed..980b402ca2d 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -713,6 +713,10 @@ Subtests signal errors if something goes wrong." "warn-wide-docstring-multiline.el" "defvar.*foo.*wider than.*characters") +(bytecomp--define-warning-file-test + "nowarn-inline-after-defvar.el" + "Lexical argument shadows" 'reverse) + ;;;; Macro expansion. -- cgit v1.2.3 From e1902ac6182b156efaaf93013a707abb4b627765 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 23 Jan 2021 23:31:13 +0000 Subject: Fix recently uncovered 'make check' failures For discussion, see the following thread: https://lists.gnu.org/r/emacs-devel/2021-01/msg01111.html * test/lisp/autorevert-tests.el (auto-revert-test07-auto-revert-several-buffers): * test/lisp/emacs-lisp/seq-tests.el (test-seq-do-indexed) (test-seq-random-elt-take-all): Fix errors from using add-to-list on lexical variables. * test/lisp/emacs-lisp/cl-lib-tests.el (cl-lib-defstruct-record): Expect test to succeed when byte-compiled following change of 2021-01-23 'Fix missing file&line info in "Unknown defun property" warnings'. (cl-lib-tests--dummy-function): Remove; no longer needed. (old-struct): Silence byte-compiler warning about unused lexical variable. --- test/lisp/autorevert-tests.el | 19 ++++++++++--------- test/lisp/emacs-lisp/cl-lib-tests.el | 9 +-------- test/lisp/emacs-lisp/seq-tests.el | 23 ++++++++++------------- 3 files changed, 21 insertions(+), 30 deletions(-) (limited to 'test/lisp/emacs-lisp') diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 683e3ea30d4..45cf6353960 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -609,11 +609,12 @@ This expects `auto-revert--messages' to be bound by (should auto-revert-mode)) (dotimes (i num-buffers) - (add-to-list - 'buffers - (make-indirect-buffer - (car buffers) (format "%s-%d" (buffer-file-name (car buffers)) i) 'clone) - 'append)) + (push (make-indirect-buffer + (car buffers) + (format "%s-%d" (buffer-file-name (car buffers)) i) + 'clone) + buffers)) + (setq buffers (nreverse buffers)) (dolist (buf buffers) (with-current-buffer buf (should (string-equal (buffer-string) "any text")) @@ -640,10 +641,10 @@ This expects `auto-revert--messages' to be bound by (auto-revert-tests--write-file "any text" tmpfile (pop times)) (dotimes (i num-buffers) - (add-to-list - 'buffers - (generate-new-buffer (format "%s-%d" (file-name-nondirectory tmpfile) i)) - 'append)) + (push (generate-new-buffer + (format "%s-%d" (file-name-nondirectory tmpfile) i)) + buffers)) + (setq buffers (nreverse buffers)) (dolist (buf buffers) (with-current-buffer buf (insert-file-contents tmpfile 'visit) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 97a44c43ef7..065ca4fa651 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -543,15 +543,7 @@ (apply (lambda (x) (+ x 1)) (list 8))))) '(5 (6 5) (6 6) 9)))) -(defun cl-lib-tests--dummy-function () - ;; Dummy function to see if the file is compiled. - t) - (ert-deftest cl-lib-defstruct-record () - ;; This test fails when compiled, see Bug#24402/27718. - :expected-result (if (byte-code-function-p - (symbol-function 'cl-lib-tests--dummy-function)) - :failed :passed) (cl-defstruct foo x) (let ((x (make-foo :x 42))) (should (recordp x)) @@ -566,6 +558,7 @@ (should (eq (type-of x) 'vector)) (cl-old-struct-compat-mode 1) + (defvar cl-struct-foo) (let ((cl-struct-foo (cl--struct-get-class 'foo))) (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) (should (eq (type-of x) 'foo)) diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 670398354a6..05c7fbe781e 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -29,6 +29,9 @@ (require 'ert) (require 'seq) +(eval-when-compile + (require 'cl-lib)) + (defmacro with-test-sequences (spec &rest body) "Successively bind VAR to a list, vector, and string built from SEQ. Evaluate BODY for each created sequence. @@ -108,16 +111,12 @@ Evaluate BODY for each created sequence. '((a 0) (b 1) (c 2) (d 3))))) (ert-deftest test-seq-do-indexed () - (let ((result nil)) - (seq-do-indexed (lambda (elt i) - (add-to-list 'result (list elt i))) - nil) - (should (equal result nil))) + (let (result) + (seq-do-indexed (lambda (elt i) (push (list elt i) result)) ()) + (should-not result)) (with-test-sequences (seq '(4 5 6)) - (let ((result nil)) - (seq-do-indexed (lambda (elt i) - (add-to-list 'result (list elt i))) - seq) + (let (result) + (seq-do-indexed (lambda (elt i) (push (list elt i) result)) seq) (should (equal (seq-elt result 0) '(6 2))) (should (equal (seq-elt result 1) '(5 1))) (should (equal (seq-elt result 2) '(4 0)))))) @@ -410,12 +409,10 @@ Evaluate BODY for each created sequence. (ert-deftest test-seq-random-elt-take-all () (let ((seq '(a b c d e)) - (elts '())) - (should (= 0 (length elts))) + elts) (dotimes (_ 1000) (let ((random-elt (seq-random-elt seq))) - (add-to-list 'elts - random-elt))) + (cl-pushnew random-elt elts))) (should (= 5 (length elts))))) (ert-deftest test-seq-random-elt-signal-on-empty () -- cgit v1.2.3