diff --git a/etc/NEWS b/etc/NEWS index 74ad886db07..5bcd9d0f700 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -480,6 +480,21 @@ simplified away. This warning can be suppressed using 'with-suppressed-warnings' with the warning name 'suspicious'. +--- +*** Warn about more ignored function return values. +The compiler now warns when the return value from certain functions is +ignored. Example: + + (progn (nreverse my-list) my-list) + +will elicit a warning because it is usually pointless to call +'nreverse' on a list without using the returned value. To silence the +warning, make use of the value in some way, such as assigning it to a +variable. You can also wrap the function call in '(ignore ...)'. + +This warning can be suppressed using 'with-suppressed-warnings' with +the warning name 'ignored-return-value'. + +++ ** New function 'file-user-uid'. This function is like 'user-uid', but is aware of file name handlers, diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 70317e2365d..dad3bd694a6 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1706,7 +1706,7 @@ See Info node `(elisp) Integer Basics'." charsetp commandp cons consp current-buffer current-global-map current-indentation current-local-map current-minor-mode-maps current-time - eobp eolp eq equal + eobp eolp eq equal eql floatp following-char framep hash-table-p identity indirect-function integerp integer-or-marker-p diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 4a10ae29804..1b28fcd5093 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -3502,7 +3502,67 @@ lambda-expression." ;; so maybe we don't need to bother about it here? (setq form (cons 'progn (cdr form))) (setq handler #'byte-compile-progn)) - ((and (or sef (eq (car form) 'mapcar)) + ((and (or sef + (memq (car form) + ;; FIXME: Use a function property (declaration) + ;; instead of this list. + '( + ;; Functions that are side-effect-free + ;; except for the behaviour of + ;; functions passed as argument. + mapcar mapcan mapconcat + cl-mapcar cl-mapcan cl-maplist cl-map cl-mapcon + cl-reduce + assoc assoc-default plist-get plist-member + cl-assoc cl-assoc-if cl-assoc-if-not + cl-rassoc cl-rassoc-if cl-rassoc-if-not + cl-member cl-member-if cl-member-if-not + cl-adjoin + cl-mismatch cl-search + cl-find cl-find-if cl-find-if-not + cl-position cl-position-if cl-position-if-not + cl-count cl-count-if cl-count-if-not + cl-remove cl-remove-if cl-remove-if-not + cl-member cl-member-if cl-member-if-not + cl-remove-duplicates + cl-subst cl-subst-if cl-subst-if-not + cl-substitute cl-substitute-if + cl-substitute-if-not + cl-sublis + cl-union cl-intersection + cl-set-difference cl-set-exclusive-or + cl-subsetp + cl-every cl-some cl-notevery cl-notany + cl-tree-equal + + ;; Functions that mutate and return a list. + cl-delete-if cl-delete-if-not + ;; `delete-dups' and `delete-consecutive-dups' + ;; never delete the first element so it's + ;; safe to ignore their return value, but + ;; this isn't the case with + ;; `cl-delete-duplicates'. + cl-delete-duplicates + cl-nsubst cl-nsubst-if cl-nsubst-if-not + cl-nsubstitute cl-nsubstitute-if + cl-nsubstitute-if-not + cl-nunion cl-nintersection + cl-nset-difference cl-nset-exclusive-or + cl-nreconc cl-nsublis + cl-merge + ;; It's safe to ignore the value of `sort' + ;; and `nreverse' when used on arrays, + ;; but most calls pass lists. + nreverse + sort cl-sort cl-stable-sort + + ;; Adding the following functions yields many + ;; positives; evaluate how many of them are + ;; false first. + + ;;delq delete cl-delete + ;;nconc plist-put + ))) (byte-compile-warning-enabled-p 'ignored-return-value (car form))) (byte-compile-warn-x diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index de5eb9c2d92..a89bbc3a748 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -408,6 +408,7 @@ Other non-digit chars are considered junk. RADIX is an integer between 2 and 36, the default is 10. Signal an error if the substring between START and END cannot be parsed as an integer unless JUNK-ALLOWED is non-nil." + (declare (side-effect-free t)) (cl-check-type string string) (let* ((start (or start 0)) (len (length string)) @@ -566,6 +567,7 @@ too large if positive or too small if negative)." ;;;###autoload (defun cl-revappend (x y) "Equivalent to (append (reverse X) Y)." + (declare (side-effect-free t)) (nconc (reverse x) y)) ;;;###autoload diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 95a51a4bdde..7fee780a735 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -459,6 +459,7 @@ Thus, `(cl-list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to (defun cl-copy-list (list) "Return a copy of LIST, which may be a dotted list. The elements of LIST are not copied, just the list structure itself." + (declare (side-effect-free error-free)) (if (consp list) (let ((res nil)) (while (consp list) (push (pop list) res)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 8dc8b475a7f..41fc3b9f335 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3690,14 +3690,14 @@ macro that returns its `&whole' argument." ;;; Things that are side-effect-free. (mapc (lambda (x) (function-put x 'side-effect-free t)) - '(cl-oddp cl-evenp cl-signum last butlast cl-ldiff cl-pairlis cl-gcd + '(cl-oddp cl-evenp cl-signum cl-ldiff cl-pairlis cl-gcd cl-lcm cl-isqrt cl-floor cl-ceiling cl-truncate cl-round cl-mod cl-rem cl-subseq cl-list-length cl-get cl-getf)) ;;; Things that are side-effect-and-error-free. (mapc (lambda (x) (function-put x 'side-effect-free 'error-free)) - '(eql cl-list* cl-subst cl-acons cl-equalp - cl-random-state-p copy-tree cl-sublis)) + '(cl-list* cl-acons cl-equalp + cl-random-state-p copy-tree)) ;;; Types and assertions. diff --git a/lisp/emacs-lisp/ert-x.el b/lisp/emacs-lisp/ert-x.el index 98a017c8a8e..e8b0dd92989 100644 --- a/lisp/emacs-lisp/ert-x.el +++ b/lisp/emacs-lisp/ert-x.el @@ -563,9 +563,9 @@ The same keyword arguments are supported as in ;; Emacs's Makefile sets $HOME to a nonexistent value. Needed ;; in batch mode only, therefore. (when (and noninteractive (not (file-directory-p "~/"))) - (setenv "HOME" temporary-file-directory)) + (setenv "HOME" (directory-file-name temporary-file-directory))) (format "/mock::%s" temporary-file-directory)))) - "Temporary directory for remote file tests.") + "Temporary directory for remote file tests.") (provide 'ert-x) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 070d1223e2c..8c1d7e3c86a 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -4195,7 +4195,8 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." (let ((info (gnus-get-info group)) (active (gnus-active group))) (when info - (gnus-request-update-info info method)) + (gnus-request-update-info info method) + (setq active (gnus-active group))) (gnus-get-unread-articles-in-group info active) (unless (gnus-virtual-group-p group) (gnus-close-group group)) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index d59b5b58ceb..19b8b09de03 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -1490,7 +1490,8 @@ backend check whether the group actually exists." (gnus-request-update-info info (inline (gnus-find-method-for-group (gnus-info-group info))))) - (gnus-activate-group (gnus-info-group info) nil t)) + (gnus-activate-group (gnus-info-group info) nil t) + (setq active (gnus-active (gnus-info-group info)))) (let* ((range (gnus-info-read info)) (num 0)) diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 66577282a0f..9a2957c9f52 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -440,7 +440,7 @@ artlist; otherwise store the ARTLIST in the group parameters." (if (eq 'nnselect (car (gnus-server-to-method server))) (with-current-buffer gnus-summary-buffer (let ((thread (gnus-id-to-thread article))) - (when thread + (when (car thread) (mapc (lambda (x) (when (and x (> x 0)) @@ -594,62 +594,63 @@ artlist; otherwise store the ARTLIST in the group parameters." (gnus-newsgroup-selection (or gnus-newsgroup-selection (nnselect-get-artlist group))) newmarks) - (gnus-info-set-marks info nil) - (setf (gnus-info-read info) nil) - (pcase-dolist (`(,artgroup . ,nartids) - (ids-by-group - (number-sequence 1 (nnselect-artlist-length - gnus-newsgroup-selection)))) - (let* ((gnus-newsgroup-active nil) - (idmap (make-hash-table :test 'eql)) - (gactive (sort (mapcar 'cdr nartids) '<)) - (group-info (gnus-get-info artgroup)) - (marks (gnus-info-marks group-info))) - (pcase-dolist (`(,val . ,key) nartids) - (puthash key val idmap)) - (setf (gnus-info-read info) - (range-add-list - (gnus-info-read info) - (sort (mapcar (lambda (art) (gethash art idmap)) - (gnus-sorted-intersection - gactive - (range-uncompress (gnus-info-read group-info)))) - '<))) - (pcase-dolist (`(,type . ,mark-list) marks) - (let ((mark-type (gnus-article-mark-to-type type)) new) - (when - (setq new - (if (not mark-list) nil - (cond - ((eq mark-type 'tuple) - (delq nil - (mapcar - (lambda (mark) - (let ((id (gethash (car mark) idmap))) - (when id (cons id (cdr mark))))) - mark-list))) - (t - (mapcar (lambda (art) (gethash art idmap)) - (gnus-sorted-intersection - gactive (range-uncompress mark-list))))))) - (let ((previous (alist-get type newmarks))) - (if previous - (nconc previous new) - (push (cons type new) newmarks)))))))) + (when gnus-newsgroup-selection + (gnus-info-set-marks info nil) + (setf (gnus-info-read info) nil) + (pcase-dolist (`(,artgroup . ,nartids) + (ids-by-group + (number-sequence 1 (nnselect-artlist-length + gnus-newsgroup-selection)))) + (let* ((gnus-newsgroup-active nil) + (idmap (make-hash-table :test 'eql)) + (gactive (sort (mapcar 'cdr nartids) #'<)) + (group-info (gnus-get-info artgroup)) + (marks (gnus-info-marks group-info))) + (pcase-dolist (`(,val . ,key) nartids) + (puthash key val idmap)) + (setf (gnus-info-read info) + (range-add-list + (gnus-info-read info) + (sort (mapcar (lambda (art) (gethash art idmap)) + (gnus-sorted-intersection + gactive + (range-uncompress (gnus-info-read group-info)))) + #'<))) + (pcase-dolist (`(,type . ,mark-list) marks) + (let ((mark-type (gnus-article-mark-to-type type)) new) + (when + (setq new + (if (not mark-list) nil + (cond + ((eq mark-type 'tuple) + (delq nil + (mapcar + (lambda (mark) + (let ((id (gethash (car mark) idmap))) + (when id (cons id (cdr mark))))) + mark-list))) + (t + (mapcar (lambda (art) (gethash art idmap)) + (gnus-sorted-intersection + gactive (range-uncompress mark-list))))))) + (let ((previous (alist-get type newmarks))) + (if previous + (nconc previous new) + (push (cons type new) newmarks)))))))) - ;; Clean up the marks: compress lists; - (pcase-dolist (`(,type . ,mark-list) newmarks) - (let ((mark-type (gnus-article-mark-to-type type))) - (unless (eq mark-type 'tuple) - (setf (alist-get type newmarks) - (gnus-compress-sequence (sort mark-list '<)))))) - ;; and ensure an unexist key. - (unless (assq 'unexist newmarks) - (push (cons 'unexist nil) newmarks)) + ;; Clean up the marks: compress lists; + (pcase-dolist (`(,type . ,mark-list) newmarks) + (let ((mark-type (gnus-article-mark-to-type type))) + (unless (eq mark-type 'tuple) + (setf (alist-get type newmarks) + (gnus-compress-sequence (sort mark-list #'<)))))) + ;; and ensure an unexist key. + (unless (assq 'unexist newmarks) + (push (cons 'unexist nil) newmarks)) - (gnus-info-set-marks info newmarks) - (gnus-set-active group (cons 1 (nnselect-artlist-length - gnus-newsgroup-selection))))) + (gnus-info-set-marks info newmarks) + (gnus-set-active group (cons 1 (nnselect-artlist-length + gnus-newsgroup-selection)))))) (deffoo nnselect-request-thread (header &optional group server) @@ -759,7 +760,8 @@ artlist; otherwise store the ARTLIST in the group parameters." (deffoo nnselect-close-group (group &optional _server) (let ((group (nnselect-add-prefix group))) (unless gnus-group-is-exiting-without-update-p - (nnselect-push-info group)) + (when gnus-newsgroup-selection + (nnselect-push-info group))) (setq gnus-newsgroup-selection nil) (when (gnus-ephemeral-group-p group) (gnus-kill-ephemeral-group group) @@ -882,23 +884,28 @@ article came from is also searched." -(defun nnselect-push-info (group) +(defun nnselect-push-info (_group) "Copy mark-lists from GROUP to the originating groups." (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads)) - (select-reads (numbers-by-group - (gnus-info-read (gnus-get-info group)) 'range)) - (select-unseen (numbers-by-group gnus-newsgroup-unseen)) - (gnus-newsgroup-active nil) mark-list) + (select-reads (numbers-by-group + (gnus-sorted-difference gnus-newsgroup-articles + gnus-newsgroup-unreads))) + (select-unseen (numbers-by-group gnus-newsgroup-unseen)) + (gnus-newsgroup-active nil) mark-list) ;; collect the set of marked article lists categorized by ;; originating groups (pcase-dolist (`(,mark . ,type) gnus-article-mark-lists) - (let (type-list) - (when (setq type-list - (symbol-value (intern (format "gnus-newsgroup-%s" mark)))) - (push (cons - type - (numbers-by-group type-list (gnus-article-mark-to-type type))) - mark-list)))) + (let ((mark-type (gnus-article-mark-to-type type)) + (type-list (symbol-value + (intern (format "gnus-newsgroup-%s" mark))))) + (when type-list + (unless (eq 'tuple mark-type) + (setq type-list (range-list-intersection + gnus-newsgroup-articles type-list))) + (push (cons + type + (numbers-by-group type-list mark-type)) + mark-list)))) ;; now work on each originating group one at a time (pcase-dolist (`(,artgroup . ,artlist) (numbers-by-group gnus-newsgroup-articles)) diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el index 08fc20f438a..805c742d9e0 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el @@ -86,7 +86,8 @@ RETURN-ATTRS is a list of attributes to return, defaulting to ((eq (car term) 'email) (unless (string= (cdr term) mail) (setq matched nil))) - ((eq (car term) 'phone)))) + ;; ((eq (car term) 'phone)) + )) (when matched (setq result diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 6b788c00ba6..a4f6246ec23 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -244,8 +244,8 @@ arguments to pass to the OPERATION." (setq result (insert-file-contents (tramp-fuse-local-file-name filename) visit beg end replace)) - (when visit (setq buffer-file-name filename)) - (cons filename (cdr result))))) + (when visit (setq buffer-file-name filename))) + (cons filename (cdr result)))) (defun tramp-sshfs-handle-process-file (program &optional infile destination display &rest args) diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 3f6696fce77..e69ce4f1d12 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -2426,7 +2426,8 @@ INFO may provide the values of these header arguments (in the (delete-region (point) (org-babel-result-end))) ((member "append" result-params) (goto-char (org-babel-result-end)) (setq beg (point-marker))) - ((member "prepend" result-params))) ; already there + ;; ((member "prepend" result-params)) ; already there + ) (setq results-switches (if results-switches (concat " " results-switches) "")) (let ((wrap diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 11228226592..877d79353aa 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1248,8 +1248,10 @@ If you exit the `query-replace', you can later continue the (defun project-prefixed-buffer-name (mode) (concat "*" - (file-name-nondirectory - (directory-file-name default-directory)) + (if-let ((proj (project-current nil))) + (project-name proj) + (file-name-nondirectory + (directory-file-name default-directory))) "-" (downcase mode) "*")) @@ -1261,7 +1263,7 @@ If non-nil, it overrides `compilation-buffer-name-function' for :version "28.1" :group 'project :type '(choice (const :tag "Default" nil) - (const :tag "Prefixed with root directory name" + (const :tag "Prefixed with project name" project-prefixed-buffer-name) (function :tag "Custom function"))) diff --git a/lisp/progmodes/prolog.el b/lisp/progmodes/prolog.el index 1b48fe9c3a8..66dea8803b3 100644 --- a/lisp/progmodes/prolog.el +++ b/lisp/progmodes/prolog.el @@ -828,7 +828,7 @@ Relevant only when `prolog-imenu-flag' is non-nil." ((not (zerop (skip-chars-forward prolog-operator-chars)))) ((not (zerop (skip-syntax-forward "w_'")))) ;; In case of non-ASCII punctuation. - ((not (zerop (skip-syntax-forward "."))))) + (t (skip-syntax-forward "."))) (point)))) (defun prolog-smie-backward-token () @@ -842,7 +842,7 @@ Relevant only when `prolog-imenu-flag' is non-nil." ((not (zerop (skip-chars-backward prolog-operator-chars)))) ((not (zerop (skip-syntax-backward "w_'")))) ;; In case of non-ASCII punctuation. - ((not (zerop (skip-syntax-backward "."))))) + (t (skip-syntax-backward "."))) (point)))) (defconst prolog-smie-grammar diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index 716ab694e2c..f6bd5733ba3 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -118,20 +118,20 @@ (declare-function sm-test7 nil) (advice-add 'sm-test7 :around (lambda (f &rest args) - (list (cons 1 (called-interactively-p)) (apply f args)))) + (list (cons 1 (called-interactively-p 'any)) (apply f args)))) (should (equal (sm-test7) '((1 . nil) 11))) (should (equal (call-interactively 'sm-test7) '((1 . t) 11))) (let ((smi 7)) (advice-add 'sm-test7 :before (lambda (&rest _args) - (setq smi (called-interactively-p)))) + (setq smi (called-interactively-p 'any)))) (should (equal (list (sm-test7) smi) '(((1 . nil) 11) nil))) (should (equal (list (call-interactively 'sm-test7) smi) '(((1 . t) 11) t)))) (advice-add 'sm-test7 :around (lambda (f &rest args) - (cons (cons 2 (called-interactively-p)) (apply f args)))) + (cons (cons 2 (called-interactively-p 'any)) (apply f args)))) (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))) (ert-deftest advice-test-called-interactively-p-around () @@ -140,18 +140,18 @@ This tests the currently broken case of the innermost advice to a function being an around advice." :expected-result :failed - (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p))) + (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p 'any))) (declare-function sm-test7.2 nil) (advice-add 'sm-test7.2 :around (lambda (f &rest args) - (list (cons 1 (called-interactively-p)) (apply f args)))) + (list (cons 1 (called-interactively-p 'any)) (apply f args)))) (should (equal (sm-test7.2) '((1 . nil) (1 . nil)))) (should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t))))) (ert-deftest advice-test-called-interactively-p-filter-args () "Check interaction between filter-args advice and called-interactively-p." :expected-result :failed - (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p))) + (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p 'any))) (declare-function sm-test7.3 nil) (advice-add 'sm-test7.3 :filter-args #'list) (should (equal (sm-test7.3) '(1 . nil))) @@ -159,7 +159,9 @@ function being an around advice." (ert-deftest advice-test-call-interactively () "Check interaction between advice on call-interactively and called-interactively-p." - (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p)))) + (let ((sm-test7.4 (lambda () + (interactive) + (cons 1 (called-interactively-p 'any)))) (old (symbol-function 'call-interactively))) (unwind-protect (progn diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 3a9f5e03000..9bca6a03754 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2412,22 +2412,51 @@ This checks also `file-name-as-directory', `file-name-directory', (with-temp-buffer (write-region "foo" nil tmp-name) (let ((point (point))) - (insert-file-contents tmp-name) + (should + (equal + (insert-file-contents tmp-name) + `(,(expand-file-name tmp-name) 3))) (should (string-equal (buffer-string) "foo")) (should (= point (point)))) (goto-char (1+ (point))) (let ((point (point))) - (insert-file-contents tmp-name) + (should + (equal + (insert-file-contents tmp-name) + `(,(expand-file-name tmp-name) 3))) (should (string-equal (buffer-string) "ffoooo")) (should (= point (point)))) ;; Insert partly. (let ((point (point))) - (insert-file-contents tmp-name nil 1 3) + (should + (equal + (insert-file-contents tmp-name nil 1 3) + `(,(expand-file-name tmp-name) 2))) (should (string-equal (buffer-string) "foofoooo")) (should (= point (point)))) + (let ((point (point))) + (should + (equal + (insert-file-contents tmp-name nil 2 5) + `(,(expand-file-name tmp-name) 1))) + (should (string-equal (buffer-string) "fooofoooo")) + (should (= point (point)))) ;; Replace. (let ((point (point))) - (insert-file-contents tmp-name nil nil nil 'replace) + ;; 0 characters replaced, because "foo" is already there. + (should + (equal + (insert-file-contents tmp-name nil nil nil 'replace) + `(,(expand-file-name tmp-name) 0))) + (should (string-equal (buffer-string) "foo")) + (should (= point (point)))) + (let ((point (point))) + (replace-string-in-region "foo" "bar" (point-min) (point-max)) + (goto-char point) + (should + (equal + (insert-file-contents tmp-name nil nil nil 'replace) + `(,(expand-file-name tmp-name) 3))) (should (string-equal (buffer-string) "foo")) (should (= point (point)))) ;; Error case. diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index 62e04539ebf..86e7b21def0 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -37,8 +37,8 @@ ;; value (FIXME: like what?) in order to overwrite the default value. ;; ;; IMPORTANT: Since Eglot is a :core ELPA package, these tests are - ;;supposed to run on Emacsen down to 26.3. Do not use bleeding-edge - ;;functionality not compatible with that Emacs version. +;; supposed to run on Emacsen down to 26.3. Do not use bleeding-edge +;; functionality not compatible with that Emacs version. ;;; Code: (require 'eglot) @@ -61,16 +61,13 @@ (apply #'format format args))) (defmacro eglot--with-fixture (fixture &rest body) - "Setup FIXTURE, call BODY, teardown FIXTURE. + "Set up FIXTURE, call BODY, tear down FIXTURE. FIXTURE is a list. Its elements are of the form (FILE . CONTENT) to create a readable FILE with CONTENT. FILE may be a directory name and CONTENT another (FILE . CONTENT) list to specify a -directory hierarchy. FIXTURE's elements can also be (SYMBOL -VALUE) meaning SYMBOL should be bound to VALUE during BODY and -then restored." +directory hierarchy." (declare (indent 1) (debug t)) - `(eglot--call-with-fixture - ,fixture #'(lambda () ,@body))) + `(eglot--call-with-fixture ,fixture (lambda () ,@body))) (defun eglot--make-file-or-dir (ass) (let ((file-or-dir-name (car ass)) @@ -91,18 +88,9 @@ then restored." "Helper for `eglot--with-fixture'. Run FN under FIXTURE." (let* ((fixture-directory (make-nearby-temp-file "eglot--fixture" t)) (default-directory fixture-directory) - file-specs created-files - syms-to-restore + created-files new-servers test-body-successful-p) - (dolist (spec fixture) - (cond ((symbolp spec) - (push (cons spec (symbol-value spec)) syms-to-restore) - (set spec nil)) - ((symbolp (car spec)) - (push (cons (car spec) (symbol-value (car spec))) syms-to-restore) - (set (car spec) (cadr spec))) - ((stringp (car spec)) (push spec file-specs)))) (eglot--test-message "[%s]: test start" (ert-test-name (ert-running-test))) (unwind-protect (let* ((process-environment @@ -123,7 +111,7 @@ then restored." process-environment)) (eglot-server-initialized-hook (lambda (server) (push server new-servers)))) - (setq created-files (mapcan #'eglot--make-file-or-dir file-specs)) + (setq created-files (mapcan #'eglot--make-file-or-dir fixture)) (prog1 (funcall fn) (setq test-body-successful-p t))) (eglot--test-message "[%s]: %s" (ert-test-name (ert-running-test)) @@ -155,18 +143,15 @@ then restored." (t (eglot--test-message "Preserved for inspection: %s" (mapconcat #'buffer-name buffers ", ")))))))) - (eglot--cleanup-after-test fixture-directory created-files syms-to-restore))))) + (eglot--cleanup-after-test fixture-directory created-files))))) -(defun eglot--cleanup-after-test (fixture-directory created-files syms-to-restore) +(defun eglot--cleanup-after-test (fixture-directory created-files) (let ((buffers-to-delete - (delete nil (mapcar #'find-buffer-visiting created-files)))) - (eglot--test-message "Killing %s, wiping %s, restoring %s" + (delq nil (mapcar #'find-buffer-visiting created-files)))) + (eglot--test-message "Killing %s, wiping %s" buffers-to-delete - fixture-directory - (mapcar #'car syms-to-restore)) - (cl-loop for (sym . val) in syms-to-restore - do (set sym val)) - (dolist (buf buffers-to-delete) ;; have to save otherwise will get prompted + fixture-directory) + (dolist (buf buffers-to-delete) ;; Have to save otherwise will get prompted. (with-current-buffer buf (save-buffer) (kill-buffer))) (delete-directory fixture-directory 'recursive) ;; Delete Tramp buffers if needed. @@ -325,8 +310,7 @@ then restored." "Connect to eclipse.jdt.ls server." (skip-unless (executable-find "jdtls")) (eglot--with-fixture - '(("project/src/main/java/foo" . (("Main.java" . ""))) - ("project/.git/" . nil)) + '(("project/src/main/java/foo" . (("Main.java" . "")))) (with-current-buffer (eglot--find-file-noselect "project/src/main/java/foo/Main.java") (eglot--sniffing (:server-notifications s-notifs) @@ -480,11 +464,11 @@ then restored." (should (eq 'eglot-diagnostic-tag-unnecessary-face (face-at-point)))))))) (defun eglot--eldoc-on-demand () - ;; Trick Eldoc 1.1.0 into accepting on-demand calls. + ;; Trick ElDoc 1.1.0 into accepting on-demand calls. (eldoc t)) (defun eglot--tests-force-full-eldoc () - ;; FIXME: This uses some Eldoc implementation defatils. + ;; FIXME: This uses some ElDoc implementation details. (when (buffer-live-p eldoc--doc-buffer) (with-current-buffer eldoc--doc-buffer (let ((inhibit-read-only t)) @@ -670,7 +654,7 @@ int main() { (should (string-match "^fprintf" (eglot--tests-force-full-eldoc)))))) (ert-deftest eglot-test-multiline-eldoc () - "Test Eldoc documentation from multiple osurces." + "Test ElDoc documentation from multiple osurces." (skip-unless (executable-find "clangd")) (eglot--with-fixture `(("project" . (("coiso.c" . @@ -723,7 +707,7 @@ int main() { (eglot--sniffing (:server-notifications s-notifs) (should (eglot--tests-connect)) (eglot--wait-for (s-notifs 20) (&key method &allow-other-keys) - (string= method "textDocument/publishDiagnostics"))) + (string= method "textDocument/publishDiagnostics"))) (goto-char (point-max)) (eglot--simulate-key-event ?.) (should (looking-back "^ \\.")))))) @@ -872,9 +856,9 @@ int main() { (skip-unless (executable-find "clangd")) (eglot--with-fixture `(("project" . (("foo.c" . "int foo() {return 42;}") - ("bar.c" . "int bar() {return 42;}"))) - (c-mode-hook (eglot-ensure))) - (let (server) + ("bar.c" . "int bar() {return 42;}")))) + (let ((c-mode-hook '(eglot-ensure)) + server) ;; need `ert-simulate-command' because `eglot-ensure' ;; relies on `post-command-hook'. (with-current-buffer @@ -1288,7 +1272,7 @@ macro will assume it exists." (ert-deftest eglot-test-path-to-uri-windows () (skip-unless (eq system-type 'windows-nt)) (should (string-prefix-p "file:///" - (eglot--path-to-uri "c:/Users/Foo/bar.lisp"))) + (eglot--path-to-uri "c:/Users/Foo/bar.lisp"))) (should (string-suffix-p "c%3A/Users/Foo/bar.lisp" (eglot--path-to-uri "c:/Users/Foo/bar.lisp")))) @@ -1318,8 +1302,9 @@ macro will assume it exists." (should (eq (eglot-current-server) server)))))) (provide 'eglot-tests) -;;; eglot-tests.el ends here ;; Local Variables: ;; checkdoc-force-docstrings-flag: nil ;; End: + +;;; eglot-tests.el ends here diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 6f79d3277a8..2859123da80 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -114,22 +114,24 @@ (should-error (nreverse 1)) (should-error (nreverse (make-char-table 'foo))) (should (equal (nreverse (copy-sequence "xyzzy")) "yzzyx")) - (let ((A (vector))) - (nreverse A) - (should (equal A []))) - (let ((A (vector 0))) - (nreverse A) - (should (equal A [0]))) - (let ((A (vector 1 2 3 4))) - (nreverse A) - (should (equal A [4 3 2 1]))) - (let ((A (vector 1 2 3 4))) - (nreverse A) - (nreverse A) - (should (equal A [1 2 3 4]))) + (let* ((A (vector)) + (B (nreverse A))) + (should (equal A [])) + (should (eq B A))) + (let* ((A (vector 0)) + (B (nreverse A))) + (should (equal A [0])) + (should (eq B A))) (let* ((A (vector 1 2 3 4)) - (B (nreverse (nreverse A)))) - (should (equal A B)))) + (B (nreverse A))) + (should (equal A [4 3 2 1])) + (should (eq B A))) + (let* ((A (vector 1 2 3 4)) + (B (nreverse A)) + (C (nreverse A))) + (should (equal A [1 2 3 4])) + (should (eq B A)) + (should (eq C A)))) (ert-deftest fns-tests-reverse-bool-vector () (let ((A (make-bool-vector 10 nil))) @@ -140,9 +142,10 @@ (ert-deftest fns-tests-nreverse-bool-vector () (let ((A (make-bool-vector 10 nil))) (dotimes (i 5) (aset A i t)) - (nreverse A) - (should (equal [nil nil nil nil nil t t t t t] (vconcat A))) - (should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A)))))) + (let ((B (nreverse A))) + (should (eq B A)) + (should (equal [nil nil nil nil nil t t t t t] (vconcat A))) + (should (equal [t t t t t nil nil nil nil nil] (vconcat (nreverse A))))))) (defconst fns-tests--string-lessp-cases `(("abc" < "abd")