[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/android 618ba26ed19: Merge remote-tracking branch 'origin/master
|
From: |
Po Lu |
|
Subject: |
feature/android 618ba26ed19: Merge remote-tracking branch 'origin/master' into feature/android |
|
Date: |
Thu, 13 Apr 2023 20:02:45 -0400 (EDT) |
branch: feature/android
commit 618ba26ed190f0b4b0fe725d4e717c01ce9fbeed
Merge: e11e56a057a 2c3ca78e811
Author: Po Lu <luangruo@yahoo.com>
Commit: Po Lu <luangruo@yahoo.com>
Merge remote-tracking branch 'origin/master' into feature/android
---
doc/misc/flymake.texi | 24 ++-
etc/NEWS | 10 +-
lisp/emacs-lisp/byte-opt.el | 375 ++++++++++++++++++++++++-------------
lisp/emacs-lisp/cl-macs.el | 54 +-----
lisp/emacs-lisp/eldoc.el | 37 ++--
lisp/progmodes/eglot.el | 129 +++++++------
lisp/progmodes/flymake.el | 89 +++++++--
lisp/subr.el | 2 +-
src/data.c | 5 +-
src/eval.c | 3 +-
src/treesit.c | 201 +++++++++++++++++---
test/lisp/progmodes/eglot-tests.el | 29 +--
test/lisp/simple-tests.el | 6 +-
test/src/treesit-tests.el | 115 +++++++++---
14 files changed, 736 insertions(+), 343 deletions(-)
diff --git a/doc/misc/flymake.texi b/doc/misc/flymake.texi
index 13616f39f16..b6a540a6ea3 100644
--- a/doc/misc/flymake.texi
+++ b/doc/misc/flymake.texi
@@ -1,7 +1,7 @@
\input texinfo @c -*- mode: texinfo; coding: utf-8 -*-
@comment %**start of header
@setfilename ../../info/flymake.info
-@set VERSION 1.3.3
+@set VERSION 1.3.4
@set UPDATED April 2023
@settitle GNU Flymake @value{VERSION}
@include docstyle.texi
@@ -142,6 +142,12 @@ highlighted regions to learn what the specific problem
is. Alternatively, place point on the highlighted regions and use the
commands @code{eldoc} or @code{display-local-help}.
+Another easy way to get instant access to the diagnostic text is to
+set @code{flymake-show-diagnostics-at-end-of-line} to a non-@code{nil}
+value. This makes the diagnostic messages appear at the end of the
+line where the regular annotation is located (@pxref{Customizable
+variables})
+
@cindex next and previous diagnostic
If the diagnostics are outside the visible region of the buffer,
@code{flymake-goto-next-error} and @code{flymake-goto-prev-error} are
@@ -314,6 +320,22 @@ Which fringe (if any) should show the warning/error
bitmaps.
@item flymake-wrap-around
If non-@code{nil}, moving to errors with @code{flymake-goto-next-error} and
@code{flymake-goto-prev-error} wraps around buffer boundaries.
+
+@item flymake-show-diagnostics-at-end-of-line
+If non-@code{nil}, show summarized descriptions of diagnostics at the
+end of the line. Depending on your preference, this can either be
+distracting and easily confused with actual code, or a significant
+early aid that relieves you from moving around or reaching for the
+mouse to consult an error message.
+
+@item flymake-error-eol
+A custom face for summarizing diagnostic error messages.
+
+@item flymake-warning-eol
+A custom face for summarizing diagnostic warning messages.
+
+@item flymake-note-eol
+A custom face for summarizing diagnostic notes.
@end vtable
@node Extending Flymake
diff --git a/etc/NEWS b/etc/NEWS
index 3a44d016de2..e507ef1b55e 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -277,13 +277,21 @@ following to your init file:
#'shortdoc-help-fns-examples-function)
** Package
-
---
*** New user option 'package-vc-register-as-project'.
When non-nil, it will automatically register every package as a
project, that you can quickly select using 'project-switch-project'
('C-x p p').
+** Flymake
++++
+*** New user option 'flymake-show-diagnostics-at-end-of-line'.
+When non-nil, Flymake shows summarized descriptions of diagnostics at
+the end of the line. Depending on your preference, this can either be
+distracting and easily confused with actual code, or a significant
+early aid that relieves you from moving the buffer or reaching for the
+mouse to consult an error message.
+
* New Modes and Packages in Emacs 30.1
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index c9c94f51ef0..2bdd3375728 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1636,99 +1636,231 @@ See Info node `(elisp) Integer Basics'."
;; I wonder if I missed any :-\)
(let ((side-effect-free-fns
- '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan
- assq
- base64-decode-string base64-encode-string base64url-encode-string
+ '(
+ ;; alloc.c
+ make-bool-vector make-byte-code make-list make-record make-string
+ make-symbol make-vector
+ ;; buffer.c
+ buffer-base-buffer buffer-chars-modified-tick buffer-file-name
+ buffer-local-value buffer-local-variables buffer-modified-p
+ buffer-modified-tick buffer-name get-buffer next-overlay-change
+ overlay-buffer overlay-end overlay-get overlay-properties
+ overlay-start overlays-at overlays-in previous-overlay-change
+ ;; callint.c
+ prefix-numeric-value
+ ;; casefiddle.c
+ capitalize downcase upcase upcase-initials
+ ;; category.c
+ category-docstring category-set-mnemonics char-category-set
+ copy-category-table get-unused-category make-category-set
+ ;; character.c
+ char-width multibyte-char-to-unibyte string unibyte-char-to-multibyte
+ ;; charset.c
+ decode-char encode-char
+ ;; chartab.c
+ make-char-table
+ ;; data.c
+ % * + - / /= 1+ 1- < <= = > >=
+ aref ash bare-symbol
bool-vector-count-consecutive bool-vector-count-population
bool-vector-subsetp
- boundp buffer-file-name buffer-local-variables buffer-modified-p
- buffer-substring
- capitalize car-less-than-car car cdr ceiling char-after char-before
- char-equal char-to-string char-width compare-strings
- window-configuration-equal-p concat coordinates-in-window-p
- copy-alist copy-sequence copy-marker copysign cos
- current-time-string current-time-zone
- decode-char
- decode-time default-boundp default-value documentation downcase
- elt encode-char exp expt encode-time error-message-string
- fboundp fceiling featurep ffloor
- file-directory-p file-exists-p file-locked-p file-name-absolute-p
- file-name-concat
- file-newer-than-file-p file-readable-p file-symlink-p file-writable-p
- float float-time floor format format-message format-time-string
- frame-first-window frame-root-window frame-selected-window
- frame-visible-p fround ftruncate
- get gethash get-buffer get-buffer-window get-file-buffer
- hash-table-count
- intern-soft isnan
- keymap-parent
- ldexp
- length length< length> length=
- line-beginning-position line-end-position pos-bol pos-eol
- local-variable-if-set-p local-variable-p locale-info
- log logand logb logcount logior lognot logxor
- make-byte-code make-list make-string make-symbol marker-buffer max
- match-beginning match-end
- member memq memql min minibuffer-selected-window minibuffer-window
- mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string
- prefix-numeric-value previous-window prin1-to-string propertize
- rassq rassoc read-from-string
- regexp-quote region-beginning region-end reverse round
- sin sqrt string string-equal string-lessp
- string-search string-to-char
- string-to-number string-to-syntax substring substring-no-properties
- sxhash-equal sxhash-eq sxhash-eql
- symbol-function symbol-name symbol-plist symbol-value
- string-make-unibyte
- string-make-multibyte string-as-multibyte string-as-unibyte
- string-to-multibyte
- take tan time-convert truncate
- unibyte-char-to-multibyte upcase user-full-name
- user-login-name
- vconcat
- window-at window-body-height
- window-body-width window-buffer window-dedicated-p window-display-table
- window-combination-limit window-frame window-fringes
- window-hscroll
- window-left-child window-left-column window-margins window-minibuffer-p
- window-next-buffers window-next-sibling window-new-normal
- window-new-total window-normal-size window-parameter window-parameters
- window-parent window-point window-prev-buffers
- window-prev-sibling window-scroll-bars
- window-start window-text-height window-top-child window-top-line
- window-total-height window-total-width window-use-time window-vscroll
- ))
+ boundp car cdr default-boundp default-value fboundp
+ get-variable-watchers indirect-variable
+ local-variable-if-set-p local-variable-p
+ logand logcount logior lognot logxor max min mod
+ number-to-string position-symbol string-to-number
+ subr-arity subr-name subr-native-lambda-list subr-type
+ symbol-function symbol-name symbol-plist symbol-value
+ symbol-with-pos-pos variable-binding-locus
+ ;; doc.c
+ documentation
+ ;; editfns.c
+ buffer-substring buffer-substring-no-properties
+ byte-to-position byte-to-string
+ char-after char-before char-equal char-to-string
+ compare-buffer-substrings
+ format format-message
+ group-name
+ line-beginning-position line-end-position ngettext pos-bol pos-eol
+ propertize region-beginning region-end string-to-char
+ user-full-name user-login-name
+ ;; fileio.c
+ car-less-than-car directory-name-p file-directory-p file-exists-p
+ file-name-absolute-p file-name-concat file-newer-than-file-p
+ file-readable-p file-symlink-p file-writable-p
+ ;; filelock.c
+ file-locked-p
+ ;; floatfns.c
+ abs acos asin atan ceiling copysign cos exp expt fceiling ffloor
+ float floor fround ftruncate isnan ldexp log logb round sin sqrt tan
+ truncate
+ ;; fns.c
+ append assq
+ base64-decode-string base64-encode-string base64url-encode-string
+ compare-strings concat copy-alist copy-hash-table copy-sequence elt
+ featurep get
+ gethash hash-table-count hash-table-rehash-size
+ hash-table-rehash-threshold hash-table-size hash-table-test
+ hash-table-weakness
+ length length< length= length>
+ line-number-at-pos locale-info make-hash-table
+ member memq memql nth nthcdr
+ object-intervals rassoc rassq reverse
+ string-as-multibyte string-as-unibyte string-bytes string-distance
+ string-equal string-lessp string-make-multibyte string-make-unibyte
+ string-search string-to-multibyte substring substring-no-properties
+ sxhash-eq sxhash-eql sxhash-equal sxhash-equal-including-properties
+ take vconcat
+ ;; frame.c
+ frame-ancestor-p frame-bottom-divider-width frame-char-height
+ frame-char-width frame-child-frame-border-width frame-focus
+ frame-fringe-width frame-internal-border-width frame-native-height
+ frame-native-width frame-parameter frame-parameters frame-parent
+ frame-pointer-visible-p frame-position frame-right-divider-width
+ frame-scale-factor frame-scroll-bar-height frame-scroll-bar-width
+ frame-text-cols frame-text-height frame-text-lines frame-text-width
+ frame-total-cols frame-total-lines frame-visible-p
+ frame-window-state-change next-frame previous-frame
+ tool-bar-pixel-width window-system
+ ;; fringe.c
+ fringe-bitmaps-at-pos
+ ;; keyboard.c
+ posn-at-point posn-at-x-y
+ ;; keymap.c
+ copy-keymap keymap-parent keymap-prompt make-keymap make-sparse-keymap
+ ;; lread.c
+ intern-soft read-from-string
+ ;; marker.c
+ copy-marker marker-buffer marker-insertion-type marker-position
+ ;; minibuf.c
+ active-minibuffer-window assoc-string innermost-minibuffer-p
+ minibuffer-innermost-command-loop-p minibufferp
+ ;; print.c
+ error-message-string prin1-to-string
+ ;; process.c
+ format-network-address get-buffer-process get-process
+ process-buffer process-coding-system process-command process-filter
+ process-id process-inherit-coding-system-flag process-mark
+ process-name process-plist process-query-on-exit-flag
+ process-running-child-p process-sentinel process-thread
+ process-tty-name process-type
+ ;; search.c
+ match-beginning match-end regexp-quote
+ ;; sqlite.c
+ sqlite-columns sqlite-more-p sqlite-version
+ ;; syntax.c
+ char-syntax copy-syntax-table matching-paren string-to-syntax
+ syntax-class-to-char
+ ;; term.c
+ controlling-tty-p tty-display-color-cells tty-display-color-p
+ tty-top-frame tty-type
+ ;; terminal.c
+ frame-terminal terminal-list terminal-live-p terminal-name
+ terminal-parameter terminal-parameters
+ ;; textprop.c
+ get-char-property get-char-property-and-overlay get-text-property
+ next-char-property-change next-property-change
+ next-single-char-property-change next-single-property-change
+ previous-char-property-change previous-property-change
+ previous-single-char-property-change previous-single-property-change
+ text-properties-at text-property-any text-property-not-all
+ ;; thread.c
+ all-threads condition-mutex condition-name mutex-name thread-live-p
+ thread-name
+ ;; timefns.c
+ current-time-string current-time-zone decode-time encode-time
+ float-time format-time-string time-add time-convert time-equal-p
+ time-less-p time-subtract
+ ;; window.c
+ coordinates-in-window-p frame-first-window frame-root-window
+ frame-selected-window get-buffer-window minibuffer-selected-window
+ minibuffer-window next-window previous-window window-at
+ window-body-height window-body-width window-buffer
+ window-combination-limit window-configuration-equal-p
+ window-dedicated-p window-display-table window-frame window-fringes
+ window-hscroll window-left-child window-left-column window-margins
+ window-minibuffer-p window-new-normal window-new-total
+ window-next-buffers window-next-sibling window-normal-size
+ window-parameter window-parameters window-parent window-point
+ window-prev-buffers window-prev-sibling window-scroll-bars
+ window-start window-text-height window-top-child window-top-line
+ window-total-height window-total-width window-use-time window-vscroll
+ ;; xdisp.c
+ buffer-text-pixel-size current-bidi-paragraph-direction
+ get-display-property invisible-p line-pixel-height lookup-image-map
+ tab-bar-height tool-bar-height window-text-pixel-size
+ ))
(side-effect-and-error-free-fns
- '(arrayp atom
- bobp bolp bool-vector-p
- buffer-list buffer-size buffer-string bufferp
- byte-code-function-p
- car-safe case-table-p cdr-safe char-or-string-p characterp
- charsetp commandp cons consp
- current-buffer current-global-map current-indentation
- current-local-map current-minor-mode-maps current-time
- eobp eolp eq equal eql
- floatp following-char framep
- hash-table-p
- identity indirect-function integerp integer-or-marker-p
- invocation-directory invocation-name
- keymapp keywordp
- list listp
- make-marker mark-marker markerp max-char
- natnump nlistp null number-or-marker-p numberp
- overlayp
- point point-marker point-min point-max preceding-char
- processp proper-list-p
- recent-keys recursion-depth
- safe-length selected-frame selected-window sequencep
- standard-case-table standard-syntax-table stringp subrp symbolp
- syntax-table syntax-table-p
- this-command-keys this-command-keys-vector this-single-command-keys
- this-single-command-raw-keys type-of
- user-real-login-name user-real-uid user-uid
- vector vectorp visible-frame-list
- wholenump window-configuration-p window-live-p
- window-valid-p windowp)))
+ '(
+ ;; alloc.c
+ bool-vector cons list make-marker purecopy record vector
+ ;; buffer.c
+ buffer-list buffer-live-p current-buffer overlay-lists overlayp
+ ;; casetab.c
+ case-table-p current-case-table standard-case-table
+ ;; category.c
+ category-table category-table-p make-category-table
+ standard-category-table
+ ;; character.c
+ characterp max-char
+ ;; charset.c
+ charsetp
+ ;; data.c
+ arrayp atom bare-symbol-p bool-vector-p bufferp byte-code-function-p
+ byteorder car-safe cdr-safe char-or-string-p char-table-p
+ condition-variable-p consp eq floatp indirect-function
+ integer-or-marker-p integerp keywordp listp markerp
+ module-function-p multibyte-string-p mutexp natnump nlistp null
+ number-or-marker-p numberp recordp remove-pos-from-symbol
+ sequencep stringp subr-native-elisp-p subrp symbol-with-pos-p symbolp
+ threadp type-of user-ptrp vector-or-char-table-p vectorp wholenump
+ ;; editfns.c
+ bobp bolp buffer-size buffer-string current-message emacs-pid
+ eobp eolp following-char gap-position gap-size group-gid
+ group-real-gid mark-marker point point-marker point-max point-min
+ position-bytes preceding-char system-name
+ user-real-login-name user-real-uid user-uid
+ ;; emacs.c
+ invocation-directory invocation-name
+ ;; eval.c
+ commandp functionp
+ ;; fileio.c
+ default-file-modes
+ ;; fns.c
+ eql equal hash-table-p identity proper-list-p safe-length
+ secure-hash-algorithms
+ ;; frame.c
+ frame-list frame-live-p framep last-nonminibuffer-frame
+ old-selected-frame selected-frame visible-frame-list
+ ;; image.c
+ imagep
+ ;; indent.c
+ current-column current-indentation
+ ;; keyboard.c
+ current-idle-time current-input-mode recent-keys recursion-depth
+ this-command-keys this-command-keys-vector this-single-command-keys
+ this-single-command-raw-keys
+ ;; keymap.c
+ current-global-map current-local-map current-minor-mode-maps keymapp
+ ;; minibuf.c
+ minibuffer-contents minibuffer-contents-no-properties minibuffer-depth
+ minibuffer-prompt minibuffer-prompt-end
+ ;; process.c
+ process-list processp signal-names waiting-for-user-input-p
+ ;; sqlite.c
+ sqlite-available-p sqlitep
+ ;; syntax.c
+ standard-syntax-table syntax-table syntax-table-p
+ ;; thread.c
+ current-thread
+ ;; timefns.c
+ current-time
+ ;; window.c
+ selected-window window-configuration-p window-live-p window-valid-p
+ windowp
+ ;; xdisp.c
+ long-line-optimizations-p
+ )))
(while side-effect-free-fns
(put (car side-effect-free-fns) 'side-effect-free t)
(setq side-effect-free-fns (cdr side-effect-free-fns)))
@@ -1753,41 +1885,34 @@ See Info node `(elisp) Integer Basics'."
;; values if a marker is moved.
(let ((pure-fns
- '(concat regexp-quote
- string-to-char string-to-syntax symbol-name
- eq eql
- = /= < <= >= > min max
- + - * / % mod abs ash 1+ 1- sqrt
- logand logior lognot logxor logcount
- copysign isnan ldexp float logb
- floor ceiling round truncate
- ffloor fceiling fround ftruncate
- string-equal string-lessp
- string-search
- consp atom listp nlistp proper-list-p
- sequencep arrayp vectorp stringp bool-vector-p hash-table-p
- null
- numberp integerp floatp natnump characterp
- integer-or-marker-p number-or-marker-p char-or-string-p
- symbolp keywordp
- type-of
- identity
-
- ;; The following functions are pure up to mutation of their
- ;; arguments. This is pure enough for the purposes of
- ;; constant folding, but not necessarily for all kinds of
- ;; code motion.
- car cdr car-safe cdr-safe nth nthcdr take
- equal
- length safe-length
- memq memql member
- ;; `assoc' and `assoc-default' are excluded since they are
- ;; impure if the test function is (consider `string-match').
- assq rassq rassoc
- aref elt
- base64-decode-string base64-encode-string base64url-encode-string
- bool-vector-subsetp
- bool-vector-count-population bool-vector-count-consecutive
+ '(
+ ;; character.c
+ characterp
+ ;; data.c
+ % * + - / /= 1+ 1- < <= = > >= aref arrayp ash atom bare-symbol
+ bool-vector-count-consecutive bool-vector-count-population
+ bool-vector-p bool-vector-subsetp
+ bufferp car car-safe cdr cdr-safe char-or-string-p char-table-p
+ condition-variable-p consp eq floatp integer-or-marker-p integerp
+ keywordp listp logand logcount logior lognot logxor markerp max min
+ mod multibyte-string-p mutexp natnump nlistp null number-or-marker-p
+ numberp recordp remove-pos-from-symbol sequencep stringp symbol-name
+ symbolp threadp type-of vector-or-char-table-p vectorp
+ ;; editfns.c
+ string-to-char
+ ;; floatfns.c
+ abs ceiling copysign fceiling ffloor float floor fround ftruncate
+ isnan ldexp logb round sqrt truncate
+ ;; fns.c
+ assq base64-decode-string base64-encode-string base64url-encode-string
+ concat elt eql equal hash-table-p identity length length< length=
+ length> member memq memql nth nthcdr proper-list-p rassoc rassq
+ safe-length string-bytes string-distance string-equal string-lessp
+ string-search take
+ ;; search.c
+ regexp-quote
+ ;; syntax.c
+ string-to-syntax
)))
(while pure-fns
(put (car pure-fns) 'pure t)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 41fc3b9f335..5382e0a0a52 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2891,45 +2891,14 @@ The function's arguments should be treated as immutable.
,(format "compiler-macro for inlining `%s'." name)
(cl--defsubst-expand
',argns '(cl-block ,name ,@(cdr (macroexp-parse-body body)))
- ;; We used to pass `simple' as
- ;; (not (or unsafe (cl-expr-access-order pbody argns)))
- ;; But this is much too simplistic since it
- ;; does not pay attention to the argvs (and
- ;; cl-expr-access-order itself is also too naive).
nil
,(and (memq '&key args) 'cl-whole) nil ,@argns)))
(cl-defun ,name ,args ,@body))))
-(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs)
- (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole
- (if (cl--simple-exprs-p argvs) (setq simple t))
- (let* ((substs ())
- (lets (delq nil
- (cl-mapcar (lambda (argn argv)
- (if (or simple (macroexp-const-p argv))
- (progn (push (cons argn argv) substs)
- nil)
- (list argn argv)))
- argns argvs))))
- ;; FIXME: `sublis/subst' will happily substitute the symbol
- ;; `argn' in places where it's not used as a reference
- ;; to a variable.
- ;; FIXME: `sublis/subst' will happily copy `argv' to a different
- ;; scope, leading to name capture.
- (setq body (cond ((null substs) body)
- ((null (cdr substs))
- (cl-subst (cdar substs) (caar substs) body))
- (t (cl--sublis substs body))))
- (if lets `(let ,lets ,body) body))))
-
-(defun cl--sublis (alist tree)
- "Perform substitutions indicated by ALIST in TREE (non-destructively)."
- (let ((x (assq tree alist)))
- (cond
- (x (cdr x))
- ((consp tree)
- (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree))))
- (t tree))))
+(defun cl--defsubst-expand (argns body _simple whole _unsafe &rest argvs)
+ (if (and whole (not (cl--safe-expr-p (cons 'progn argvs))))
+ whole
+ `(let ,(cl-mapcar #'list argns argvs) ,body)))
;;; Structures.
@@ -3244,19 +3213,8 @@ To see the documentation for a defined struct type, use
(let* ((anames (cl--arglist-args args))
(make (cl-mapcar (lambda (s d) (if (memq s anames) s d))
slots defaults))
- ;; `cl-defsubst' is fundamentally broken: it substitutes
- ;; its arguments into the body's `sexp' much too naively
- ;; when inlinling, which results in various problems.
- ;; For example it generates broken code if your
- ;; argument's name happens to be the same as some
- ;; function used within the body.
- ;; E.g. (cl-defsubst sm-foo (list) (list list))
- ;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'!
- ;; Try to catch this known case!
- (con-fun (or type #'record))
- (unsafe-cl-defsubst
- (or (memq con-fun args) (assq con-fun args))))
- (push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname
+ (con-fun (or type #'record)))
+ (push `(,cldefsym ,cname
(&cl-defs (nil ,@descs) ,@args)
,(if (stringp doc) doc
(format "Constructor for objects of type `%s'." name))
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index 1eb0d38c5ce..18d3eb37af3 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -681,29 +681,34 @@ This is the default value for
`eldoc-documentation-strategy'."
(lambda (f)
(funcall f (eldoc--make-callback :eager f)))))
-(defun eldoc--documentation-compose-1 (eagerlyp)
- "Helper function for composing multiple doc strings.
-If EAGERLYP is non-nil show documentation as soon as possible,
-else wait for all doc strings."
- (run-hook-wrapped 'eldoc-documentation-functions
- (lambda (f)
- (let* ((callback (eldoc--make-callback
- (if eagerlyp :eager :patient)
- f))
- (str (funcall f callback)))
- (if (or (null str) (stringp str)) (funcall callback
str))
- nil)))
- t)
-
(defun eldoc-documentation-compose ()
"Show multiple documentation strings together after waiting for all of them.
This is meant to be used as a value for `eldoc-documentation-strategy'."
- (eldoc--documentation-compose-1 nil))
+ (let (fns-and-callbacks)
+ ;; Make all the callbacks, setting up state inside
+ ;; `eldoc--invoke-strategy' to know how many callbacks to wait for
+ ;; before displaying the result (bug#62816).
+ (run-hook-wrapped 'eldoc-documentation-functions
+ (lambda (f)
+ (push (cons f (eldoc--make-callback :patient f))
+ fns-and-callbacks)
+ nil))
+ ;; Now call them. The last one will trigger the display.
+ (cl-loop for (f . callback) in fns-and-callbacks
+ for str = (funcall f callback)
+ when (or (null str) (stringp str)) do (funcall callback str)))
+ t)
(defun eldoc-documentation-compose-eagerly ()
"Show multiple documentation strings one by one as soon as possible.
This is meant to be used as a value for `eldoc-documentation-strategy'."
- (eldoc--documentation-compose-1 t))
+ (run-hook-wrapped 'eldoc-documentation-functions
+ (lambda (f)
+ (let* ((callback (eldoc--make-callback :eager f))
+ (str (funcall f callback)))
+ (if (or (null str) (stringp str)) (funcall callback
str))
+ nil)))
+ t)
(defun eldoc-documentation-enthusiast ()
"Show most important documentation string produced so far.
diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el
index 3f00281e155..c4f773c8426 100644
--- a/lisp/progmodes/eglot.el
+++ b/lisp/progmodes/eglot.el
@@ -844,12 +844,9 @@ treated as in `eglot--dbind'."
:documentation "Short nickname for the associated project."
:accessor eglot--project-nickname
:reader eglot-project-nickname)
- (major-modes
- :documentation "Major modes server is responsible for in a given project."
- :accessor eglot--major-modes)
- (language-id
- :documentation "Language ID string for the mode."
- :accessor eglot--language-id)
+ (languages
+ :documentation "Alist ((MODE . LANGUAGE-ID-STRING)...) of managed
languages."
+ :accessor eglot--languages)
(capabilities
:documentation "JSON object containing server capabilities."
:accessor eglot--capabilities)
@@ -884,6 +881,12 @@ treated as in `eglot--dbind'."
:documentation
"Represents a server. Wraps a process for LSP communication.")
+(defun eglot--major-modes (s) "Major modes server S is responsible for."
+ (mapcar #'car (eglot--languages s)))
+
+(defun eglot--language-ids (s) "LSP Language ID strings for server S's modes."
+ (mapcar #'cdr (eglot--languages s)))
+
(cl-defmethod initialize-instance :before ((_server eglot-lsp-server)
&optional args)
(cl-remf args :initializationOptions))
@@ -969,42 +972,44 @@ PRESERVE-BUFFERS as in `eglot-shutdown', which see."
(defun eglot--lookup-mode (mode)
"Lookup `eglot-server-programs' for MODE.
-Return (MANAGED-MODES LANGUAGE-ID CONTACT-PROXY).
+Return (LANGUAGES . CONTACT-PROXY).
MANAGED-MODES is a list with MODE as its first element.
Subsequent elements are other major modes also potentially
managed by the server that is to manage MODE.
-If not specified in `eglot-server-programs' (which see),
-LANGUAGE-ID is determined from MODE's name.
+LANGUAGE-IDS is a list of the same length as MANAGED-MODES. Each
+elem is derived from the corresponding mode name, if not
+specified in `eglot-server-programs' (which see).
CONTACT-PROXY is the value of the corresponding
`eglot-server-programs' entry."
- (cl-loop
- for (modes . contact) in eglot-server-programs
- for mode-symbols = (cons mode
- (delete mode
- (mapcar #'car
- (mapcar #'eglot--ensure-list
- (eglot--ensure-list
modes)))))
- thereis (cl-some
- (lambda (spec)
- (cl-destructuring-bind (probe &key language-id &allow-other-keys)
- (eglot--ensure-list spec)
- (and (provided-mode-derived-p mode probe)
- (list
- mode-symbols
- (or language-id
- (or (get mode 'eglot-language-id)
- (get spec 'eglot-language-id)
- (string-remove-suffix "-mode" (symbol-name
mode))))
- contact))))
- (if (or (symbolp modes) (keywordp (cadr modes)))
- (list modes) modes))))
+ (cl-flet ((languages (main-mode-sym specs)
+ (let* ((res
+ (mapcar (jsonrpc-lambda (sym &key language-id
&allow-other-keys)
+ (cons sym
+ (or language-id
+ (or (get sym 'eglot-language-id)
+ (replace-regexp-in-string
+ "\\(?:-ts\\)?-mode$" ""
+ (symbol-name sym))))))
+ specs))
+ (head (cl-find main-mode-sym res :key #'car)))
+ (cons head (delq head res)))))
+ (cl-loop
+ for (modes . contact) in eglot-server-programs
+ for specs = (mapcar #'eglot--ensure-list
+ (if (or (symbolp modes) (keywordp (cadr modes)))
+ (list modes) modes))
+ thereis (cl-some (lambda (spec)
+ (cl-destructuring-bind (sym &key &allow-other-keys)
spec
+ (and (provided-mode-derived-p mode sym)
+ (cons (languages sym specs) contact))))
+ specs))))
(defun eglot--guess-contact (&optional interactive)
"Helper for `eglot'.
-Return (MANAGED-MODE PROJECT CLASS CONTACT LANG-ID). If INTERACTIVE is
+Return (MANAGED-MODES PROJECT CLASS CONTACT LANG-IDS). If INTERACTIVE is
non-nil, maybe prompt user, else error as soon as something can't
be guessed."
(let* ((guessed-mode (if buffer-file-name major-mode))
@@ -1022,11 +1027,10 @@ be guessed."
((not guessed-mode)
(eglot--error "Can't guess mode to manage for `%s'"
(current-buffer)))
(t guessed-mode)))
- (triplet (eglot--lookup-mode main-mode))
- (managed-modes (car triplet))
- (language-id (or (cadr triplet)
- (string-remove-suffix "-mode" (symbol-name
guessed-mode))))
- (guess (caddr triplet))
+ (languages-and-contact (eglot--lookup-mode main-mode))
+ (managed-modes (mapcar #'car (car languages-and-contact)))
+ (language-ids (mapcar #'cdr (car languages-and-contact)))
+ (guess (cdr languages-and-contact))
(guess (if (functionp guess)
(funcall guess interactive)
guess))
@@ -1074,7 +1078,7 @@ be guessed."
full-program-invocation
'eglot-command-history)))
guess)))
- (list managed-modes (eglot--current-project) class contact language-id)))
+ (list managed-modes (eglot--current-project) class contact language-ids)))
(defvar eglot-lsp-context)
(put 'eglot-lsp-context 'variable-documentation
@@ -1092,24 +1096,25 @@ suitable root directory for a given LSP server's
purposes."
`(transient . ,(expand-file-name default-directory)))))
;;;###autoload
-(defun eglot (managed-major-mode project class contact language-id
+(defun eglot (managed-major-modes project class contact language-ids
&optional _interactive)
- "Start LSP server in support of PROJECT's buffers under MANAGED-MAJOR-MODE.
+ "Start LSP server for PROJECT's buffers under MANAGED-MAJOR-MODES.
-This starts a Language Server Protocol (LSP) server suitable for the
-buffers of PROJECT whose `major-mode' is MANAGED-MAJOR-MODE.
-CLASS is the class of the LSP server to start and CONTACT specifies
-how to connect to the server.
+This starts a Language Server Protocol (LSP) server suitable for
+the buffers of PROJECT whose `major-mode' is among
+MANAGED-MAJOR-MODES. CLASS is the class of the LSP server to
+start and CONTACT specifies how to connect to the server.
-Interactively, the command attempts to guess MANAGED-MAJOR-MODE
-from the current buffer's `major-mode', CLASS and CONTACT from
-`eglot-server-programs' looked up by the major mode, and PROJECT from
-`project-find-functions'. The search for active projects in this
-context binds `eglot-lsp-context' (which see).
+Interactively, the command attempts to guess MANAGED-MAJOR-MODES,
+CLASS, CONTACT, and LANGUAGE-IDS from `eglot-server-programs',
+according to the current buffer's `major-mode'. PROJECT is
+guessed from `project-find-functions'. The search for active
+projects in this context binds `eglot-lsp-context' (which see).
-If it can't guess, it prompts the user for the mode and the server.
-With a single \\[universal-argument] prefix arg, it always prompts for COMMAND.
-With two \\[universal-argument], it also always prompts for MANAGED-MAJOR-MODE.
+If it can't guess, it prompts the user for the mode and the
+server. With a single \\[universal-argument] prefix arg, it
+always prompts for COMMAND. With two \\[universal-argument], it
+also always prompts for MANAGED-MAJOR-MODE.
The LSP server of CLASS is started (or contacted) via CONTACT.
If this operation is successful, current *and future* file
@@ -1127,8 +1132,8 @@ CONTACT specifies how to contact the server. It is a
keyword-value plist used to initialize CLASS or a plain list as
described in `eglot-server-programs', which see.
-LANGUAGE-ID is the language ID string to send to the server for
-MANAGED-MAJOR-MODE, which matters to a minority of servers.
+LANGUAGE-IDS is a list of language ID string to send to the
+server for each element in MANAGED-MAJOR-MODES.
INTERACTIVE is ignored and provided for backward compatibility."
(interactive
@@ -1139,8 +1144,9 @@ INTERACTIVE is ignored and provided for backward
compatibility."
(user-error "[eglot] Connection attempt aborted by user."))
(prog1 (append (eglot--guess-contact t) '(t))
(when current-server (ignore-errors (eglot-shutdown current-server))))))
- (eglot--connect (eglot--ensure-list managed-major-mode)
- project class contact language-id))
+ (eglot--connect (eglot--ensure-list managed-major-modes)
+ project class contact
+ (eglot--ensure-list language-ids)))
(defun eglot-reconnect (server &optional interactive)
"Reconnect to SERVER.
@@ -1152,7 +1158,7 @@ INTERACTIVE is t if called interactively."
(eglot--project server)
(eieio-object-class-name server)
(eglot--saved-initargs server)
- (eglot--language-id server))
+ (eglot--language-ids server))
(eglot--message "Reconnected!"))
(defvar eglot--managed-mode) ; forward decl
@@ -1225,8 +1231,8 @@ Each function is passed the server as an argument")
(defvar-local eglot--cached-server nil
"A cached reference to the current Eglot server.")
-(defun eglot--connect (managed-modes project class contact language-id)
- "Connect to MANAGED-MODES, LANGUAGE-ID, PROJECT, CLASS and CONTACT.
+(defun eglot--connect (managed-modes project class contact language-ids)
+ "Connect to MANAGED-MODES, LANGUAGE-IDS, PROJECT, CLASS and CONTACT.
This docstring appeases checkdoc, that's all."
(let* ((default-directory (project-root project))
(nickname (project-name project))
@@ -1299,8 +1305,9 @@ This docstring appeases checkdoc, that's all."
(setf (eglot--saved-initargs server) initargs)
(setf (eglot--project server) project)
(setf (eglot--project-nickname server) nickname)
- (setf (eglot--major-modes server) (eglot--ensure-list managed-modes))
- (setf (eglot--language-id server) language-id)
+ (setf (eglot--languages server)
+ (cl-loop for m in managed-modes for l in language-ids
+ collect (cons m l)))
(setf (eglot--inferior-process server) autostart-inferior-process)
(run-hook-with-args 'eglot-server-initialized-hook server)
;; Now start the handshake. To honor `eglot-sync-connect'
@@ -2354,7 +2361,7 @@ THINGS are either registrations or unregisterations
(sic)."
(append
(eglot--VersionedTextDocumentIdentifier)
(list :languageId
- (eglot--language-id (eglot--current-server-or-lose))
+ (alist-get major-mode (eglot--languages
(eglot--current-server-or-lose)))
:text
(eglot--widening
(buffer-substring-no-properties (point-min) (point-max))))))
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index c751e5bd432..f2fe97cb773 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -4,7 +4,7 @@
;; Author: Pavel Kobyakov <pk_at_work@yahoo.com>
;; Maintainer: João Távora <joaotavora@gmail.com>
-;; Version: 1.3.3
+;; Version: 1.3.4
;; Keywords: c languages tools
;; Package-Requires: ((emacs "26.1") (eldoc "1.14.0") (project "0.7.1"))
@@ -431,6 +431,26 @@ verify FILTER, a function, and sort them by COMPARE (using
KEY)."
"Face used for marking note regions."
:version "26.1")
+(defface flymake-error-echo
+ '((t :inherit compilation-error))
+ "Face used for showing summarized descriptions of errors."
+ :package-version '("Flymake" . "1.3.4"))
+
+(defface flymake-warning-echo
+ '((t :inherit compilation-warning))
+ "Face used for showing summarized descriptions of warnings."
+ :package-version '("Flymake" . "1.3.4"))
+
+(defface flymake-note-echo
+ '((t :inherit flymake-note))
+ "Face used for showing summarized descriptions of notes."
+ :package-version '("Flymake" . "1.3.4"))
+
+(defcustom flymake-show-diagnostics-at-end-of-line nil
+ "If non-nil, add diagnostic summary messages at end-of-line."
+ :type 'boolean
+ :package-version '("Flymake" . "1.3.4"))
+
(define-obsolete-face-alias 'flymake-warnline 'flymake-warning "26.1")
(define-obsolete-face-alias 'flymake-errline 'flymake-error "26.1")
@@ -584,22 +604,25 @@ Node `(Flymake)Flymake error types'"
(put 'flymake-error 'face 'flymake-error)
(put 'flymake-error 'flymake-bitmap 'flymake-error-bitmap)
(put 'flymake-error 'severity (warning-numeric-level :error))
-(put 'flymake-error 'mode-line-face 'compilation-error)
-(put 'flymake-error 'echo-face 'error)
+(put 'flymake-error 'mode-line-face 'flymake-error-echo)
+(put 'flymake-error 'echo-face 'flymake-error-echo)
+(put 'flymake-error 'eol-face 'flymake-error-echo)
(put 'flymake-error 'flymake-type-name "error")
(put 'flymake-warning 'face 'flymake-warning)
(put 'flymake-warning 'flymake-bitmap 'flymake-warning-bitmap)
(put 'flymake-warning 'severity (warning-numeric-level :warning))
-(put 'flymake-warning 'mode-line-face 'compilation-warning)
-(put 'flymake-warning 'echo-face 'warning)
+(put 'flymake-warning 'mode-line-face 'flymake-warning-echo)
+(put 'flymake-warning 'echo-face 'flymake-warning-echo)
+(put 'flymake-warning 'eol-face 'flymake-warning-echo)
(put 'flymake-warning 'flymake-type-name "warning")
(put 'flymake-note 'face 'flymake-note)
(put 'flymake-note 'flymake-bitmap 'flymake-note-bitmap)
(put 'flymake-note 'severity (warning-numeric-level :debug))
-(put 'flymake-note 'mode-line-face 'compilation-info)
-(put 'flymake-note 'echo-face 'compilation-info)
+(put 'flymake-note 'mode-line-face 'flymake-note-echo)
+(put 'flymake-note 'echo-face 'flymake-note-echo)
+(put 'flymake-note 'eol-face 'flymake-note-echo)
(put 'flymake-note 'flymake-type-name "note")
(defun flymake--lookup-type-property (type prop &optional default)
@@ -656,6 +679,12 @@ associated `flymake-category' return DEFAULT."
flymake-diagnostic-text)
always (equal (funcall comp a) (funcall comp b)))))
+(defun flymake--delete-overlay (ov)
+ "Like `delete-overlay', delete OV, but do some more stuff."
+ (let ((eolov (overlay-get ov 'eol-ov)))
+ (when eolov (delete-overlay eolov))
+ (delete-overlay ov)))
+
(cl-defun flymake--highlight-line (diagnostic &optional foreign)
"Attempt to overlay DIAGNOSTIC in current buffer.
@@ -695,6 +724,7 @@ Return nil or the overlay created."
;; diagnostic is already registered in the same place, which only
;; happens for clashes between domestic and foreign diagnostics
(cl-loop for e in (flymake-diagnostics beg end)
+ for eov = (flymake--diag-overlay e)
when (flymake--equal-diagnostic-p e diagnostic)
;; FIXME. This is an imperfect heuristic. Ideally, we'd
;; want to delete no overlays and keep annotating the
@@ -710,7 +740,7 @@ Return nil or the overlay created."
(flymake--diag-orig-beg e)
(flymake--diag-end e)
(flymake--diag-orig-end e))
- (delete-overlay (flymake--diag-overlay e))))
+ (flymake--delete-overlay eov)))
(setq ov (make-overlay end beg))
(setf (flymake--diag-beg diagnostic) (overlay-start ov)
(flymake--diag-end diagnostic) (overlay-end ov))
@@ -728,6 +758,37 @@ Return nil or the overlay created."
(flymake--lookup-type-property type 'flymake-overlay-control))
(alist-get type flymake-diagnostic-types-alist))
do (overlay-put ov ov-prop value))
+ ;; Handle `flymake-show-diagnostics-at-end-of-line'
+ ;;
+ (when-let ((eol-face (and flymake-show-diagnostics-at-end-of-line
+ (flymake--lookup-type-property type 'eol-face))))
+ (save-excursion
+ (goto-char (overlay-start ov))
+ (let* ((start (line-end-position))
+ (end (min (1+ start) (point-max)))
+ (eolov (car
+ (cl-remove-if-not
+ (lambda (o) (overlay-get o 'flymake-source-ovs))
+ (overlays-at start))))
+ (bs (flymake-diagnostic-oneliner diagnostic t)))
+ (setq bs (propertize bs 'face eol-face))
+ ;; FIXME: 1. no checking if there are unexpectedly more than
+ ;; one eolov at point. 2. The first regular source ov to
+ ;; die also kills the eolov (very rare this matters, but
+ ;; could be improved).
+ (cond (eolov
+ (overlay-put eolov 'before-string
+ (concat (overlay-get eolov 'before-string) " "
bs))
+ (overlay-put eolov 'flymake-source-ovs
+ (cons ov (overlay-get eolov
'flymake-source-ovs))))
+ (t
+ (setq eolov (make-overlay start end nil t nil))
+ (setq bs (concat " " bs))
+ (put-text-property 0 1 'cursor t bs)
+ (overlay-put eolov 'before-string bs)
+ (overlay-put eolov 'evaporate (not (= start end)))
+ (overlay-put eolov 'flymake-source-ovs (list ov))
+ (overlay-put ov 'eol-ov eolov))))))
;; Now ensure some essential defaults are set
;;
(cl-flet ((default-maybe
@@ -743,6 +804,8 @@ Return nil or the overlay created."
'flymake-bitmap
(alist-get 'bitmap (alist-get type ; backward compat
flymake-diagnostic-types-alist)))))
+ ;; (default-maybe 'after-string
+ ;; (flymake--diag-text diagnostic))
(default-maybe 'help-echo
(lambda (window _ov pos)
(with-selected-window window
@@ -873,7 +936,7 @@ report applies to that region."
(maphash (lambda (_buffer diags)
(cl-loop for d in diags
when (flymake--diag-overlay d)
- do (delete-overlay it)))
+ do (flymake--delete-overlay it)))
(flymake--state-foreign-diags state))
(clrhash (flymake--state-foreign-diags state)))
@@ -900,7 +963,7 @@ and other buffers."
(flymake--intersects-p
(overlay-start ov) (overlay-end ov)
(car region) (cdr region)))
- do (delete-overlay ov)
+ do (flymake--delete-overlay ov)
else collect diag into surviving
finally (setf (flymake--state-diags state)
surviving)))
@@ -909,7 +972,7 @@ and other buffers."
(not (flymake--state-reported-p state))
(cl-loop for diag in (flymake--state-diags state)
for ov = (flymake--diag-overlay diag)
- when ov do (delete-overlay ov))
+ when ov do (flymake--delete-overlay ov))
(setf (flymake--state-diags state) nil)
;; Also clear all overlays for `foreign-diags' in all other
;; buffers.
@@ -1153,7 +1216,7 @@ special *Flymake log* buffer." :group 'flymake :lighter
;; existing diagnostic overlays, lest we forget them by blindly
;; reinitializing `flymake--state' in the next line.
;; See https://github.com/joaotavora/eglot/issues/223.
- (mapc #'delete-overlay (flymake--overlays))
+ (mapc #'flymake--delete-overlay (flymake--overlays))
(setq flymake--state (make-hash-table))
(setq flymake--recent-changes nil)
@@ -1200,7 +1263,7 @@ special *Flymake log* buffer." :group 'flymake :lighter
(when flymake-timer
(cancel-timer flymake-timer)
(setq flymake-timer nil))
- (mapc #'delete-overlay (flymake--overlays))
+ (mapc #'flymake--delete-overlay (flymake--overlays))
(when flymake--state
(maphash (lambda (_backend state)
(flymake--clear-foreign-diags state))
diff --git a/lisp/subr.el b/lisp/subr.el
index 46faff1cd18..649f64df57a 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -829,7 +829,7 @@ of course, also replace TO with a slightly larger value
If TREE is a cons cell, this recursively copies both its car and its cdr.
Contrast to `copy-sequence', which copies only along the cdrs. With second
argument VECP, this copies vectors as well as conses."
- (declare (side-effect-free t))
+ (declare (side-effect-free error-free))
(if (consp tree)
(let (result)
(while (consp tree)
diff --git a/src/data.c b/src/data.c
index 8dc5000424e..4ab37e86ce5 100644
--- a/src/data.c
+++ b/src/data.c
@@ -4217,10 +4217,11 @@ syms_of_data (void)
Fput (Qrecursion_error, Qerror_message, build_pure_c_string
("Excessive recursive calling error"));
- PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
- "Variable binding depth exceeds max-specpdl-size");
PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail,
"Lisp nesting exceeds `max-lisp-eval-depth'");
+ /* Error obsolete (from 29.1), kept for compatibility. */
+ PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
+ "Variable binding depth exceeds max-specpdl-size");
/* Types that type-of returns. */
DEFSYM (Qinteger, "integer");
diff --git a/src/eval.c b/src/eval.c
index 1a4d3ad0307..545a280ae91 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2373,8 +2373,7 @@ grow_specpdl_allocation (void)
union specbinding *pdlvec = specpdl - 1;
ptrdiff_t size = specpdl_end - specpdl;
ptrdiff_t pdlvecsize = size + 1;
- if (max_size <= size)
- xsignal0 (Qexcessive_variable_binding); /* Can't happen, essentially. */
+ eassert (max_size > size);
pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
specpdl = pdlvec + 1;
specpdl_end = specpdl + pdlvecsize - 1;
diff --git a/src/treesit.c b/src/treesit.c
index fd5fda78133..45b5ab15390 100644
--- a/src/treesit.c
+++ b/src/treesit.c
@@ -3139,10 +3139,84 @@ treesit_traverse_child_helper (TSTreeCursor *cursor,
}
}
-/* Return true if the node at CURSOR matches PRED. PRED can be a
- string or a function. This function assumes PRED is either a
- string or a function. If NAMED is true, also check that the node
- is named. */
+/* Validate the PRED passed to treesit_traverse_match_predicate. If
+ there's an error, set SIGNAL_DATA to something signal accepts, and
+ return false, otherwise return true. */
+static bool
+treesit_traverse_validate_predicate (Lisp_Object pred,
+ Lisp_Object *signal_data)
+{
+ if (STRINGP (pred))
+ return true;
+ /* We want to allow cl-labels-defined functions, so we allow
+ symbols. */
+ else if (FUNCTIONP (pred) || SYMBOLP (pred))
+ return true;
+ else if (CONSP (pred))
+ {
+ Lisp_Object car = XCAR (pred);
+ Lisp_Object cdr = XCDR (pred);
+ if (EQ (car, Qnot))
+ {
+ if (!CONSP (cdr))
+ {
+ *signal_data = list2 (build_string ("Invalide `not' "
+ "predicate"),
+ pred);
+ return false;
+ }
+ /* At this point CDR must be a cons. */
+ if (XFIXNUM (Flength (cdr)) != 1)
+ {
+ *signal_data = list2 (build_string ("`not' can only "
+ "have one argument"),
+ pred);
+ return false;
+ }
+ return treesit_traverse_validate_predicate (XCAR (cdr),
+ signal_data);
+ }
+ else if (EQ (car, Qor))
+ {
+ if (!CONSP (cdr) || NILP (cdr))
+ {
+ *signal_data = list2 (build_string ("`or' must have a list "
+ "of patterns as "
+ "arguments "),
+ pred);
+ return false;
+ }
+ FOR_EACH_TAIL (cdr)
+ {
+ if (!treesit_traverse_validate_predicate (XCAR (cdr),
+ signal_data))
+ return false;
+ }
+ return true;
+ }
+ /* We allow the function to be a symbol to support cl-label. */
+ else if (STRINGP (car) && (FUNCTIONP (cdr) || SYMBOLP (cdr)))
+ return true;
+ }
+ *signal_data = list2 (build_string ("Invalid predicate, see TODO for "
+ "valid forms of predicate"),
+ pred);
+ return false;
+}
+
+/* Return true if the node at CURSOR matches PRED. PRED can be a lot
+ of things:
+
+ PRED := string | function | (string . function)
+ | (or PRED...) | (not PRED)
+
+ See docstring of treesit-search-forward and friends for the meaning
+ of each shape.
+
+ This function assumes PRED is in one of its valid forms. If NAMED
+ is true, also check that the node is named.
+
+ This function may signal if the predicate function signals. */
static bool
treesit_traverse_match_predicate (TSTreeCursor *cursor, Lisp_Object pred,
Lisp_Object parser, bool named)
@@ -3156,24 +3230,62 @@ treesit_traverse_match_predicate (TSTreeCursor *cursor,
Lisp_Object pred,
const char *type = ts_node_type (node);
return fast_c_string_match (pred, type, strlen (type)) >= 0;
}
- else
+ /* We want to allow cl-labels-defined functions, so we allow
+ symbols. */
+ else if (FUNCTIONP (pred) || SYMBOLP (pred))
{
Lisp_Object lisp_node = make_treesit_node (parser, node);
return !NILP (CALLN (Ffuncall, pred, lisp_node));
}
+ else if (CONSP (pred))
+ {
+ Lisp_Object car = XCAR (pred);
+ Lisp_Object cdr = XCDR (pred);
+
+ if (EQ (car, Qnot))
+ return !treesit_traverse_match_predicate (cursor, XCAR (cdr),
+ parser, named);
+ else if (EQ (car, Qor))
+ {
+ FOR_EACH_TAIL (cdr)
+ {
+ if (treesit_traverse_match_predicate (cursor, XCAR (cdr),
+ parser, named))
+ return true;
+ }
+ return false;
+ }
+ /* We want to allow cl-labels-defined functions, so we allow
+ symbols. */
+ else if (STRINGP (car) && (FUNCTIONP (cdr) || SYMBOLP (cdr)))
+ {
+ /* A bit of code duplication here, but should be fine. */
+ const char *type = ts_node_type (node);
+ if (!(fast_c_string_match (pred, type, strlen (type)) >= 0))
+ return false;
+
+ Lisp_Object lisp_node = make_treesit_node (parser, node);
+ if (NILP (CALLN (Ffuncall, pred, lisp_node)))
+ return false;
+
+ return true;
+ }
+ }
+ /* Returning false is better than UB. */
+ return false;
}
-/* Traverse the parse tree starting from CURSOR. PRED can be a
- function (takes a node and returns nil/non-nil), or a string
- (treated as regexp matching the node's type, must be all single
- byte characters). If the node satisfies PRED, leave CURSOR on that
- node and return true. If no node satisfies PRED, move CURSOR back
- to starting position and return false.
+/* Traverse the parse tree starting from CURSOR. See TODO for the
+ shapes PRED can have. If the node satisfies PRED, leave CURSOR on
+ that node and return true. If no node satisfies PRED, move CURSOR
+ back to starting position and return false.
LIMIT is the number of levels we descend in the tree. FORWARD
controls the direction in which we traverse the tree, true means
forward, false backward. If SKIP_ROOT is true, don't match ROOT.
- */
+
+ This function may signal if the predicate function signals. */
+
static bool
treesit_search_dfs (TSTreeCursor *cursor,
Lisp_Object pred, Lisp_Object parser,
@@ -3209,7 +3321,10 @@ treesit_search_dfs (TSTreeCursor *cursor,
START. PRED, PARSER, NAMED, FORWARD are the same as in
ts_search_subtree. If a match is found, leave CURSOR at that node,
and return true, if no match is found, return false, and CURSOR's
- position is undefined. */
+ position is undefined.
+
+ This function may signal if the predicate function signals. */
+
static bool
treesit_search_forward (TSTreeCursor *cursor,
Lisp_Object pred, Lisp_Object parser,
@@ -3219,8 +3334,7 @@ treesit_search_forward (TSTreeCursor *cursor,
nodes. This way repeated call of this function traverses each
node in the tree once and only once:
- (while node (setq node (treesit-search-forward node)))
- */
+ (while node (setq node (treesit-search-forward node))) */
bool initial = true;
while (true)
{
@@ -3247,6 +3361,14 @@ treesit_search_forward (TSTreeCursor *cursor,
}
}
+/* Clean up the given tree cursor CURSOR. */
+
+static void
+treesit_traverse_cleanup_cursor (void *cursor)
+{
+ ts_tree_cursor_delete (cursor);
+}
+
DEFUN ("treesit-search-subtree",
Ftreesit_search_subtree,
Streesit_search_subtree, 2, 5, 0,
@@ -3266,11 +3388,13 @@ Return the first matched node, or nil if none matches.
*/)
Lisp_Object all, Lisp_Object depth)
{
CHECK_TS_NODE (node);
- CHECK_TYPE (STRINGP (predicate) || FUNCTIONP (predicate),
- list3 (Qor, Qstringp, Qfunctionp), predicate);
CHECK_SYMBOL (all);
CHECK_SYMBOL (backward);
+ Lisp_Object signal_data = Qnil;
+ if (!treesit_traverse_validate_predicate (predicate, &signal_data))
+ xsignal1 (Qtreesit_invalid_predicate, signal_data);
+
/* We use a default limit of 1000. See bug#59426 for the
discussion. */
ptrdiff_t the_limit = treesit_recursion_limit;
@@ -3288,14 +3412,17 @@ Return the first matched node, or nil if none matches.
*/)
if (!treesit_cursor_helper (&cursor, XTS_NODE (node)->node, parser))
return return_value;
+ specpdl_ref count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (treesit_traverse_cleanup_cursor, &cursor);
+
if (treesit_search_dfs (&cursor, predicate, parser, NILP (backward),
NILP (all), the_limit, false))
{
TSNode node = ts_tree_cursor_current_node (&cursor);
return_value = make_treesit_node (parser, node);
}
- ts_tree_cursor_delete (&cursor);
- return return_value;
+
+ return unbind_to (count, return_value);
}
DEFUN ("treesit-search-forward",
@@ -3332,11 +3459,13 @@ always traverse leaf nodes first, then upwards. */)
Lisp_Object all)
{
CHECK_TS_NODE (start);
- CHECK_TYPE (STRINGP (predicate) || FUNCTIONP (predicate),
- list3 (Qor, Qstringp, Qfunctionp), predicate);
CHECK_SYMBOL (all);
CHECK_SYMBOL (backward);
+ Lisp_Object signal_data = Qnil;
+ if (!treesit_traverse_validate_predicate (predicate, &signal_data))
+ xsignal1 (Qtreesit_invalid_predicate, signal_data);
+
treesit_initialize ();
Lisp_Object parser = XTS_NODE (start)->parser;
@@ -3345,20 +3474,25 @@ always traverse leaf nodes first, then upwards. */)
if (!treesit_cursor_helper (&cursor, XTS_NODE (start)->node, parser))
return return_value;
+ specpdl_ref count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (treesit_traverse_cleanup_cursor, &cursor);
+
if (treesit_search_forward (&cursor, predicate, parser,
NILP (backward), NILP (all)))
{
TSNode node = ts_tree_cursor_current_node (&cursor);
return_value = make_treesit_node (parser, node);
}
- ts_tree_cursor_delete (&cursor);
- return return_value;
+
+ return unbind_to (count, return_value);
}
/* Recursively traverse the tree under CURSOR, and append the result
subtree to PARENT's cdr. See more in Ftreesit_induce_sparse_tree.
Note that the top-level children list is reversed, because
- reasons. */
+ reasons.
+
+ This function may signal if the predicate function signals. */
static void
treesit_build_sparse_tree (TSTreeCursor *cursor, Lisp_Object parent,
Lisp_Object pred, Lisp_Object process_fn,
@@ -3444,8 +3578,10 @@ a regexp. */)
Lisp_Object depth)
{
CHECK_TS_NODE (root);
- CHECK_TYPE (STRINGP (predicate) || FUNCTIONP (predicate),
- list3 (Qor, Qstringp, Qfunctionp), predicate);
+
+ Lisp_Object signal_data = Qnil;
+ if (!treesit_traverse_validate_predicate (predicate, &signal_data))
+ xsignal1 (Qtreesit_invalid_predicate, signal_data);
if (!NILP (process_fn))
CHECK_TYPE (FUNCTIONP (process_fn), Qfunctionp, process_fn);
@@ -3467,10 +3603,16 @@ a regexp. */)
to use treesit_cursor_helper. */
TSTreeCursor cursor = ts_tree_cursor_new (XTS_NODE (root)->node);
+ specpdl_ref count = SPECPDL_INDEX ();
+ record_unwind_protect_ptr (treesit_traverse_cleanup_cursor, &cursor);
+
treesit_build_sparse_tree (&cursor, parent, predicate, process_fn,
the_limit, parser);
- ts_tree_cursor_delete (&cursor);
+
+ unbind_to (count, Qnil);
+
Fsetcdr (parent, Fnreverse (Fcdr (parent)));
+
if (NILP (Fcdr (parent)))
return Qnil;
else
@@ -3571,6 +3713,7 @@ syms_of_treesit (void)
DEFSYM (Qoutdated, "outdated");
DEFSYM (Qhas_error, "has-error");
DEFSYM (Qlive, "live");
+ DEFSYM (Qnot, "not");
DEFSYM (QCanchor, ":anchor");
DEFSYM (QCequal, ":equal");
@@ -3595,6 +3738,7 @@ syms_of_treesit (void)
"user-emacs-directory");
DEFSYM (Qtreesit_parser_deleted, "treesit-parser-deleted");
DEFSYM (Qtreesit_pattern_expand, "treesit-pattern-expand");
+ DEFSYM (Qtreesit_invalid_predicate, "treesit-invalid-predicate");
DEFSYM (Qor, "or");
@@ -3622,6 +3766,9 @@ syms_of_treesit (void)
define_error (Qtreesit_parser_deleted,
"This parser is deleted and cannot be used",
Qtreesit_error);
+ define_error (Qtreesit_invalid_predicate,
+ "Invalid predicate, see TODO for valid forms for a predicate",
+ Qtreesit_error);
DEFVAR_LISP ("treesit-load-name-override-list",
Vtreesit_load_name_override_list,
diff --git a/test/lisp/progmodes/eglot-tests.el
b/test/lisp/progmodes/eglot-tests.el
index efb0f4d8844..d96ba2ebf07 100644
--- a/test/lisp/progmodes/eglot-tests.el
+++ b/test/lisp/progmodes/eglot-tests.el
@@ -1041,7 +1041,8 @@ int main() {
(cl-defmacro eglot--guessing-contact ((interactive-sym
prompt-args-sym
guessed-class-sym guessed-contact-sym
- &optional guessed-lang-id-sym)
+ &optional guessed-major-modes-sym
+ guessed-lang-ids-sym)
&body body)
"Guess LSP contact with `eglot--guessing-contact', evaluate BODY.
@@ -1051,10 +1052,10 @@ BODY is evaluated twice, with INTERACTIVE bound to the
boolean passed to
If the user would have been prompted, PROMPT-ARGS-SYM is bound to
the list of arguments that would have been passed to
`read-shell-command', else nil. GUESSED-CLASS-SYM,
-GUESSED-CONTACT-SYM and GUESSED-LANG-ID-SYM are bound to the
-useful return values of `eglot--guess-contact'. Unless the
-server program evaluates to \"a-missing-executable.exe\", this
-macro will assume it exists."
+GUESSED-CONTACT-SYM, GUESSED-LANG-IDS-SYM and
+GUESSED-MAJOR-MODES-SYM are bound to the useful return values of
+`eglot--guess-contact'. Unless the server program evaluates to
+\"a-missing-executable.exe\", this macro will assume it exists."
(declare (indent 1) (debug t))
(let ((i-sym (cl-gensym)))
`(dolist (,i-sym '(nil t))
@@ -1070,8 +1071,9 @@ macro will assume it exists."
`(lambda (&rest args) (setq ,prompt-args-sym args) "")
`(lambda (&rest _dummy) ""))))
(cl-destructuring-bind
- (_ _ ,guessed-class-sym ,guessed-contact-sym
- ,(or guessed-lang-id-sym '_))
+ (,(or guessed-major-modes-sym '_)
+ _ ,guessed-class-sym ,guessed-contact-sym
+ ,(or guessed-lang-ids-sym '_))
(eglot--guess-contact ,i-sym)
,@body))))))
@@ -1166,16 +1168,17 @@ macro will assume it exists."
(ert-deftest eglot-test-server-programs-guess-lang ()
(let ((major-mode 'foo-mode))
(let ((eglot-server-programs '((foo-mode . ("prog-executable")))))
- (eglot--guessing-contact (_ nil _ _ guessed-lang)
- (should (equal guessed-lang "foo"))))
+ (eglot--guessing-contact (_ nil _ _ _ guessed-langs)
+ (should (equal guessed-langs '("foo")))))
(let ((eglot-server-programs '(((foo-mode :language-id "bar")
. ("prog-executable")))))
- (eglot--guessing-contact (_ nil _ _ guessed-lang)
- (should (equal guessed-lang "bar"))))
+ (eglot--guessing-contact (_ nil _ _ _ guessed-langs)
+ (should (equal guessed-langs '("bar")))))
(let ((eglot-server-programs '(((baz-mode (foo-mode :language-id "bar"))
. ("prog-executable")))))
- (eglot--guessing-contact (_ nil _ _ guessed-lang)
- (should (equal guessed-lang "bar"))))))
+ (eglot--guessing-contact (_ nil _ _ modes guessed-langs)
+ (should (equal guessed-langs '("bar" "baz")))
+ (should (equal modes '(foo-mode baz-mode)))))))
(defun eglot--glob-match (glob str)
(funcall (eglot--glob-compile glob t t) str))
diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index 28d8120f143..7dabb735522 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -839,7 +839,7 @@ See Bug#21722."
(forward-line 2)
(narrow-to-region (pos-bol) (pos-eol))
(should (equal (line-number-at-pos) 1))
- (line-number-at-pos nil t)
+ (should (equal (line-number-at-pos nil t) 3))
(should (equal (line-number-at-pos) 1))))
(ert-deftest line-number-at-pos-keeps-point ()
@@ -849,8 +849,8 @@ See Bug#21722."
(goto-char (point-min))
(forward-line 2)
(setq pos (point))
- (line-number-at-pos)
- (line-number-at-pos nil t)
+ (should (equal (line-number-at-pos) 3))
+ (should (equal (line-number-at-pos nil t) 3))
(should (equal pos (point))))))
(ert-deftest line-number-at-pos-when-passing-point ()
diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el
index 468cd221ef9..26a21c34152 100644
--- a/test/src/treesit-tests.el
+++ b/test/src/treesit-tests.el
@@ -257,6 +257,7 @@
(defmacro treesit--ert-search-setup (&rest body)
"Setup macro used by `treesit-search-forward' and friends.
BODY is the test body."
+ (declare (debug (&rest form)))
`(with-temp-buffer
(let (parser root array)
(progn
@@ -332,6 +333,58 @@ BODY is the test body."
do (should (equal (treesit-node-text cursor)
text)))))
+(ert-deftest treesit-search-forward-predicate ()
+ "Test various form of supported predicates in search functions."
+ (skip-unless (treesit-language-available-p 'json))
+ (treesit--ert-search-setup
+ ;; The following tests are adapted from `treesit-search-forward'.
+
+ ;; Test `or'
+ (cl-loop for cursor = (treesit-node-child array 0)
+ then (treesit-search-forward cursor `(or "number" ,(rx "["))
+ nil t)
+ for text in '("[" "[" "1" "2" "3"
+ "[" "4" "5" "6"
+ "[" "7" "8" "9")
+ while cursor
+ do (should (equal (treesit-node-text cursor) text)))
+ ;; Test `not' and `or'
+ (cl-loop for cursor = (treesit-node-child array 0)
+ then (treesit-search-forward cursor
+ `(not (or "number" ,(rx "[")))
+ nil t)
+ for text in '("[" "," "," "]"
+ "[1,2,3]" ","
+ "," "," "]"
+ "[4,5,6]" ","
+ "," "," "]"
+ "[7,8,9]" "]"
+ "[[1,2,3], [4,5,6], [7,8,9]]")
+ while cursor
+ do (should (equal (treesit-node-text cursor) text)))
+ ;; Test (regexp . function)
+ (cl-labels ((is-odd (string)
+ (and (eq 1 (length string))
+ (cl-oddp (string-to-number string)))))
+ (cl-loop for cursor = (treesit-node-child array 0)
+ then (treesit-search-forward cursor '("number" . is-odd)
+ nil t)
+ for text in '("[" "1" "3" "5" "7" "9")
+ while cursor
+ do (should (equal (treesit-node-text cursor) text))))))
+
+(ert-deftest treesit-search-forward-predicate-invalid-predicate ()
+ "Test tree-sitter's ability to detect invalid predicates."
+ (skip-unless (treesit-language-available-p 'json))
+ (treesit--ert-search-setup
+ (dolist (pred '( 1 (not 1) (not "2" "3") (or) (or 1)))
+ (should-error (treesit-search-forward (treesit-node-child array 0)
+ pred)
+ :type 'treesit-invalid-predicate))
+ (should-error (treesit-search-forward (treesit-node-child array 0)
+ 'not-a-function)
+ :type 'void-function)))
+
(ert-deftest treesit-cursor-helper-with-missing-node ()
"Test treesit_cursor_helper with a missing node."
(skip-unless (treesit-language-available-p 'json))
@@ -831,7 +884,7 @@ the return value is ((1 3) (1 3))."
(funcall fn)))))
(defun treesit--ert-test-defun-navigation
- (init program master &optional opening closing)
+ (init program master tactic &optional opening closing)
"Run defun navigation tests on PROGRAM and MASTER.
INIT is a setup function that runs right after this function
@@ -843,6 +896,8 @@ starting marker position, and the rest are marker positions
the
corresponding navigation should stop at (after running
`treesit-defun-skipper').
+TACTIC is the same as in `treesit--navigate-thing'.
+
OPENING and CLOSING are the same as in
`treesit--ert-insert-and-parse-marker', by default they are \"[\"
and \"]\"."
@@ -873,7 +928,7 @@ and \"]\"."
(if-let ((pos (funcall
#'treesit--navigate-thing
(point) (car conf) (cdr conf)
- regexp pred)))
+ regexp pred tactic)))
(save-excursion
(goto-char pos)
(funcall treesit-defun-skipper)
@@ -1025,43 +1080,42 @@ the prev-beg, now point should be at marker 103\",
etc.")
"Test defun navigation."
(skip-unless (treesit-language-available-p 'python))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'nested))
- (require 'python)
- (treesit--ert-test-defun-navigation
- 'python-ts-mode
- treesit--ert-defun-navigation-python-program
- treesit--ert-defun-navigation-nested-master)))
+ (require 'python)
+ (treesit--ert-test-defun-navigation
+ 'python-ts-mode
+ treesit--ert-defun-navigation-python-program
+ treesit--ert-defun-navigation-nested-master
+ 'nested))
(ert-deftest treesit-defun-navigation-nested-2 ()
"Test defun navigation using `js-ts-mode'."
(skip-unless (treesit-language-available-p 'javascript))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'nested))
- (require 'js)
- (treesit--ert-test-defun-navigation
- 'js-ts-mode
- treesit--ert-defun-navigation-js-program
- treesit--ert-defun-navigation-nested-master)))
+ (require 'js)
+ (treesit--ert-test-defun-navigation
+ 'js-ts-mode
+ treesit--ert-defun-navigation-js-program
+ treesit--ert-defun-navigation-nested-master
+ 'nested))
(ert-deftest treesit-defun-navigation-nested-3 ()
"Test defun navigation using `bash-ts-mode'."
(skip-unless (treesit-language-available-p 'bash))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'nested))
- (treesit--ert-test-defun-navigation
- (lambda ()
- (treesit-parser-create 'bash)
- (setq-local treesit-defun-type-regexp "function_definition"))
- treesit--ert-defun-navigation-bash-program
- treesit--ert-defun-navigation-nested-master)))
+ (treesit--ert-test-defun-navigation
+ (lambda ()
+ (treesit-parser-create 'bash)
+ (setq-local treesit-defun-type-regexp "function_definition"))
+ treesit--ert-defun-navigation-bash-program
+ treesit--ert-defun-navigation-nested-master
+ 'nested))
(ert-deftest treesit-defun-navigation-nested-4 ()
"Test defun navigation using Elixir.
This tests bug#60355."
(skip-unless (treesit-language-available-p 'elixir))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'nested)
- (pred (lambda (node)
+ (let ((pred (lambda (node)
(member (treesit-node-text
(treesit-node-child-by-field-name node "target"))
'("def" "defmodule")))))
@@ -1070,18 +1124,19 @@ This tests bug#60355."
(treesit-parser-create 'elixir)
(setq-local treesit-defun-type-regexp `("call" . ,pred)))
treesit--ert-defun-navigation-elixir-program
- treesit--ert-defun-navigation-nested-master)))
+ treesit--ert-defun-navigation-nested-master
+ 'nested)))
(ert-deftest treesit-defun-navigation-top-level ()
"Test top-level only defun navigation."
(skip-unless (treesit-language-available-p 'python))
;; Nested defun navigation
- (let ((treesit-defun-tactic 'top-level))
- (require 'python)
- (treesit--ert-test-defun-navigation
- 'python-ts-mode
- treesit--ert-defun-navigation-python-program
- treesit--ert-defun-navigation-top-level-master)))
+ (require 'python)
+ (treesit--ert-test-defun-navigation
+ 'python-ts-mode
+ treesit--ert-defun-navigation-python-program
+ treesit--ert-defun-navigation-top-level-master
+ 'top-level))
;; TODO
;; - Functions in treesit.el