procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge remote-tracking branch 'origin/master' into feature/android

Browse source
This commit is contained in:
Po Lu 2023-04-14 08:02:14 +08:00
commit 618ba26ed1
14 changed files with 736 additions and 343 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
doc/misc/flymake.texi
View file

@ -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

10
etc/NEWS
View file

@ -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

375
lisp/emacs-lisp/byte-opt.el
View file

@ -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)

54
lisp/emacs-lisp/cl-macs.el
View file

@ -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))

37
lisp/emacs-lisp/eldoc.el
View file

@ -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.

129
lisp/progmodes/eglot.el
View file

@ -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))))))

89
lisp/progmodes/flymake.el
View file

@ -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))

2
lisp/subr.el
View file

@ -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)

5
src/data.c
View file

@ -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");

3
src/eval.c
View file

@ -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;

201
src/treesit.c
View file

@ -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,

29
test/lisp/progmodes/eglot-tests.el
View file

@ -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))

6
test/lisp/simple-tests.el
View file

@ -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 ()

115
test/src/treesit-tests.el
View file

@ -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