Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-23 05:17:35 +00:00
Code Issues Projects Releases Packages Wiki Activity

Merge remote-tracking branch 'origin/master' into scratch/pkg

Browse source
This commit is contained in:
Gerd Möllmann 2023-12-03 06:19:27 +01:00
commit a8eb9731a1
88 changed files with 2346 additions and 1140 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
admin/authors.el
View file

@ -176,6 +176,7 @@ files.")
("Miha Rihtaršič" "Miha Rihtarsic")
("Mikio Nakajima" "Nakajima Mikio")
("Nelson Jose dos Santos Ferreira" "Nelson Ferreira")
("Noah Peart" "noah\\.v\\.peart@gmail\\.com")
("Noorul Islam" "Noorul Islam K M")
;;; ("Tetsurou Okazaki" "OKAZAKI Tetsurou") ; FIXME?
("Óscar Fuentes" "Oscar Fuentes")

3
configure.ac
View file

@ -5158,6 +5158,9 @@ if test "${with_native_compilation}" = "default"; then
# Check if libgccjit really works.
AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken])
fi
if test "$with_unexec" = yes; then
with_native_compilation=no
fi
fi
if test "${with_native_compilation}" != "no"; then

4
doc/emacs/custom.texi
View file

@ -2007,8 +2007,8 @@ the one for @kbd{C-c C-x x} in Texinfo mode:
(keymap-set texinfo-mode-map "C-c p"
'backward-paragraph)
(keymap-set texinfo-mode-map "C-c n"
'forward-paragraph)))
(keymap-set texinfo-mode-map "C-c C-x x" nil)
'forward-paragraph)
(keymap-set texinfo-mode-map "C-c C-x x" nil)))
@end example
@node Modifier Keys

4
doc/emacs/files.texi
View file

@ -547,6 +547,10 @@ buffer name with the buffer's default directory (@pxref{File Names}).
to that major mode, in most cases. The command
@code{set-visited-file-name} also does this. @xref{Choosing Modes}.
If you wish to save the current buffer to a different file without
visiting that file, use @code{mark-whole-buffer} (@kbd{C-x h}), then
@w{@kbd{M-x write-region}} (@pxref{Misc File Ops}).
If Emacs is about to save a file and sees that the date of the latest
version on disk does not match what Emacs last read or wrote, Emacs
notifies you of this fact, because it probably indicates a problem caused

15
doc/emacs/fixit.texi
View file

@ -295,8 +295,8 @@ Kill the spell-checker subprocess.
@item M-@key{TAB}
@itemx @key{ESC} @key{TAB}
@itemx C-M-i
Complete the word before point based on the spelling dictionary
(@code{ispell-complete-word}).
Complete the word before point based on the spelling dictionary and
other completion sources (@code{completion-at-point}).
@item M-x flyspell-mode
Enable Flyspell mode, which highlights all misspelled words.
@item M-x flyspell-prog-mode
@ -398,14 +398,11 @@ Quit interactive spell-checking and kill the spell-checker subprocess.
Show the list of options.
@end table
@findex ispell-complete-word
In Text mode and related modes, @kbd{M-@key{TAB}}
(@code{ispell-complete-word}) performs in-buffer completion based on
spelling correction. Insert the beginning of a word, and then type
@kbd{M-@key{TAB}}; this shows a list of completions. (If your
Use the command @kbd{M-@key{TAB}} (@code{completion-at-point}) to
complete the word at point. Insert the beginning of a word, and then
type @kbd{M-@key{TAB}} to select from a list of completions. (If your
window manager intercepts @kbd{M-@key{TAB}}, type @w{@kbd{@key{ESC}
@key{TAB}}} or @kbd{C-M-i}.) Each completion is listed with a digit or
character; type that digit or character to choose it.
@key{TAB}}} or @kbd{C-M-i}.)
@cindex @code{ispell} program
@findex ispell-kill-ispell

5
doc/emacs/regs.texi
View file

@ -16,9 +16,8 @@ jump back to that position once or many times.
we will denote by @var{r}; @var{r} can be a letter (such as @samp{a})
or a number (such as @samp{1}); case matters, so register @samp{a} is
not the same as register @samp{A}. You can also set a register in
non-alphanumeric characters, for instance @samp{*} or @samp{C-d}.
Note, it's not possible to set a register in @samp{C-g} or @samp{ESC},
because these keys are reserved for quitting (@pxref{Quitting}).
non-alphanumeric characters, for instance @samp{C-d} by using for
example @key{C-q} @samp{C-d}.
@findex view-register
A register can store a position, a piece of text, a rectangle, a

12
doc/emacs/text.texi
View file

@ -943,12 +943,12 @@ situations where you shouldn't change the major mode---in mail
composition, for instance.
@kindex M-TAB @r{(Text mode)}
Text mode binds @kbd{M-@key{TAB}} to @code{ispell-complete-word}.
This command performs completion of the partial word in the buffer
before point, using the spelling dictionary as the space of possible
words. @xref{Spelling}. If your window manager defines
@kbd{M-@key{TAB}} to switch windows, you can type @kbd{@key{ESC}
@key{TAB}} or @kbd{C-M-i} instead.
The command @kbd{M-@key{TAB}} (@code{completion-at-point}) performs
completion of the partial word in the buffer before point, using the
spelling dictionary as the space of possible words by default.
@xref{Spelling}. If your window manager defines @kbd{M-@key{TAB}} to
switch windows, you can type @kbd{@key{ESC} @key{TAB}} or @kbd{C-M-i}
instead.
@vindex text-mode-hook
Entering Text mode runs the mode hook @code{text-mode-hook}

31
doc/lispintro/emacs-lisp-intro.texi
View file

@ -5445,7 +5445,11 @@ That expression starts with @code{get-buffer-create buffer}. The
function tells the computer to use the buffer with the name specified
as the one to which you are copying, or if such a buffer does not
exist, to create it. Then, the @code{with-current-buffer} function
evaluates its body with that buffer temporarily current.
evaluates its body with that buffer temporarily current, after which
it will switch back to the buffer we are at now@footnote{It is like
calling @w{@code{(save-excursion (set-buffer @dots{}) @dots{})}} in
one go, though it is defined slightly differently which interested
reader can find out using @code{describe-function}.}.
(This demonstrates another way to shift the computer's attention but
not the user's. The @code{append-to-buffer} function showed how to do
@ -5982,12 +5986,12 @@ In outline, the whole function looks like this:
(and @var{are-both-transient-mark-mode-and-mark-active-true})
(push-mark))
(let (@var{determine-size-and-set-it})
(goto-char
(@var{if-there-is-an-argument}
@var{figure-out-where-to-go}
@var{else-go-to}
(point-min))))
@var{do-nicety}
(goto-char
(@var{if-there-is-an-argument}
@var{figure-out-where-to-go}
@var{else-go-to}
(point-min))))
@var{do-nicety}
@end group
@end smallexample
@ -6040,12 +6044,13 @@ like this:
@group
(if (> (buffer-size) 10000)
;; @r{Avoid overflow for large buffer sizes!}
(* (prefix-numeric-value arg)
(/ size 10))
(* (prefix-numeric-value arg)
(/ size 10))
(/
(+ 10
(*
size (prefix-numeric-value arg))) 10)))
(* size
(prefix-numeric-value arg)))
10))
@end group
@end smallexample
@ -6182,7 +6187,7 @@ The code looks like this:
@c Keep this on one line.
@smallexample
(/ (+ 10 (* size (prefix-numeric-value arg))) 10))
(/ (+ 10 (* size (prefix-numeric-value arg))) 10)
@end smallexample
@need 1200
@ -6199,7 +6204,7 @@ enclosing expression:
(*
size
(prefix-numeric-value arg)))
10))
10)
@end group
@end smallexample

15
doc/lispref/modes.texi
View file

@ -986,9 +986,9 @@ allows users to customize a single mode hook
@deffn Command text-mode
Text mode is a major mode for editing human languages. It defines the
@samp{"} and @samp{\} characters as having punctuation syntax
(@pxref{Syntax Class Table}), and binds @kbd{M-@key{TAB}} to
@code{ispell-complete-word} (@pxref{Spelling,,, emacs, The GNU Emacs
Manual}).
(@pxref{Syntax Class Table}), and arranges for
@code{completion-at-point} to complete words based on the spelling
dictionary (@pxref{Completion in Buffers}).
An example of a major mode derived from Text mode is HTML mode.
@xref{HTML Mode,,SGML and HTML Modes, emacs, The GNU Emacs Manual}.
@ -1382,15 +1382,6 @@ the conventions listed above:
st)
"Syntax table used while in `text-mode'.")
@end group
;; @r{Create the keymap for this mode.}
@group
(defvar-keymap text-mode-map
:doc "Keymap for `text-mode'.
Many other modes, such as `mail-mode' and `outline-mode', inherit all
the commands defined in this map."
"C-M-i" #'ispell-complete-word)
@end group
@end smallexample
Here is how the actual mode command is defined now:

3
doc/lispref/processes.texi
View file

@ -1516,6 +1516,9 @@ If @var{process} is a process object which contains the property
@code{remote-pid}, or @var{process} is a number and @var{remote} is a
remote file name, @var{process} is interpreted as process on the
respective remote host, which will be the process to signal.
If @var{process} is a string, it is interpreted as process object with
the respective process name, or as a number.
@end deffn
Sometimes, it is necessary to send a signal to a non-local

3
doc/misc/dbus.texi
View file

@ -1418,6 +1418,9 @@ The name @var{service} does not exist on the bus.
@item :not-owner
We are not an owner of the name @var{service}.
@end table
When @var{service} is not a known name but a unique name, the function
returns nil.
@end defun
When a name has been chosen, Emacs can offer its own methods, which

3
doc/misc/epa.texi
View file

@ -640,6 +640,9 @@ Customize variable @code{epg-pinentry-mode} to @code{loopback} in
Emacs.
@end enumerate
Note that loopback Pinentry does not work with @command{gpgsm},
therefore EasyPG will ignore this setting for it.
There are other options available to use Emacs as Pinentry, you might
come across a Pinentry called @command{pinentry-emacs} or
@command{gpg-agent} option @code{allow-emacs-pinentry}. However,

2
doc/misc/gnus.texi
View file

@ -21596,7 +21596,7 @@ Search Groups}).
Search queries can be specified one of two ways: either using the
syntax of the engine responsible for the group you're searching, or
using Gnus' generalized search syntax. Set the option
@code{gnus-search-use-parsed-queries} to a non-@code{nil} value to used the
@code{gnus-search-use-parsed-queries} to a non-@code{nil} value to use the
generalized syntax. The advantage of this syntax is that, if you have
multiple backends indexed by different engines, you don't need to
remember which one you're searching---it's also possible to issue the

2
doc/misc/tramp.texi
View file

@ -5240,7 +5240,7 @@ Yes. @command{OpenSSH} has added support for @acronym{FIDO} hardware
devices via special key types @option{*-sk}. @value{tramp} supports
the additional handshaking messages for them. This requires at least
@command{OpenSSH} 8.2, and a @acronym{FIDO} @acronym{U2F} compatible
security key, like yubikey, solokey, or nitrokey.
security key, like yubikey, solokey, nitrokey, or titankey.
@item

29
etc/NEWS
View file

@ -496,6 +496,21 @@ It also controls how to move point when encountering a boundary
(e.g., if every line is visible, invoking 'dired-next-line' at
the last line will move to the first line). The default is nil.
*** New user option 'dired-filename-display-length'.
It is an integer representing the maximum display length of filenames.
The middle part of filename whose length exceeds the restriction is
hidden and an ellipsis is displayed instead. A value of 'window'
means using the right edge of window as the display restriction. The
default is nil.
*** New user option 'shell-command-guess-functions'.
It defines how to populate a list of commands available
for 'M-!', 'M-&', '!', '&' and the context menu "Open With"
based on marked files in Dired. Possible backends are
'dired-guess-default', MIME types, XDG configuration
and a universal command such as "open" or "start"
that delegates to the OS.
** Ediff
---
@ -1125,6 +1140,20 @@ showcases all their customization options.
* Incompatible Lisp Changes in Emacs 30.1
---
** 'register-preview-delay' is no longer used.
Register preview is no more delayed. If you want to disable it use
'register-use-preview' instead with a boolean value.
+++
** 'M-TAB' now invokes 'completion-at-point' also in Text mode.
Text mode no longer binds 'M-TAB' to 'ispell-complete-word', and
instead this mode arranges for 'completion-at-point', globally bound
to 'M-TAB', to perform word completion as well. If you want 'M-TAB'
to invoke 'ispell-complete-word', as it did in previous Emacs
versions, customize the new option
'text-mode-meta-tab-ispell-complete-word' to non-nil.
** 'pp' and 'pp-to-string' now always include a terminating newline.
In the past they included a terminating newline in most cases but not all.

10
etc/PROBLEMS
View file

@ -534,6 +534,16 @@ is to downgrade to a version of GnuPG older than 2.4.1 (or, in the
future, upgrade to a newer version which solves the problem, when such
a fixed version becomes available).
*** EasyPG loopback pinentry does not work with gpgsm.
This happens with the 'gpgsm' command from all versions of GnuPG.
EasyPG relies on the machine-parseable interface that is provided by
'gpg2' with option '--status-fd', but gpgsm does not support this.
As a workaround, input the passphrase with a GUI-capable pinentry
program like 'pinentry-gnome' or 'pinentry-qt5'. Alternatively, you
can use the 'pinentry' package from Emacs 25.
*** Emacs running on WSL receives stray characters as input.
For example, you could see Emacs inserting 'z' characters even though

28
exec/config.guess vendored
View file

@ -1,10 +1,10 @@
#!/usr/bin/sh
# Attempt to guess a canonical system name.
# Copyright 1992-2022 Free Software Foundation, Inc.
# Copyright 1992-2023 Free Software Foundation, Inc.
# shellcheck disable=SC2006,SC2268 # see below for rationale
timestamp='2022-05-25'
timestamp='2023-06-23'
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@ -47,7 +47,7 @@ me=`echo "$0" | sed -e 's,.*/,,'`
usage="\
Usage: $0 [OPTION]
Output the configuration name of the system \`$me' is run on.
Output the configuration name of the system '$me' is run on.
Options:
-h, --help print this help, then exit
@ -60,13 +60,13 @@ version="\
GNU config.guess ($timestamp)
Originally written by Per Bothner.
Copyright 1992-2022 Free Software Foundation, Inc.
Copyright 1992-2023 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
help="
Try \`$me --help' for more information."
Try '$me --help' for more information."
# Parse command line
while test $# -gt 0 ; do
@ -102,8 +102,8 @@ GUESS=
# temporary files to be created and, as you can see below, it is a
# headache to deal with in a portable fashion.
# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still
# use `HOST_CC' if defined, but it is deprecated.
# Historically, 'CC_FOR_BUILD' used to be named 'HOST_CC'. We still
# use 'HOST_CC' if defined, but it is deprecated.
# Portable tmp directory creation inspired by the Autoconf team.
@ -459,7 +459,7 @@ case $UNAME_MACHINE:$UNAME_SYSTEM:$UNAME_RELEASE:$UNAME_VERSION in
UNAME_RELEASE=`uname -v`
;;
esac
# Japanese Language versions have a version number like `4.1.3-JL'.
# Japanese Language versions have a version number like '4.1.3-JL'.
SUN_REL=`echo "$UNAME_RELEASE" | sed -e 's/-/_/'`
GUESS=sparc-sun-sunos$SUN_REL
;;
@ -966,6 +966,12 @@ EOF
GNU_REL=`echo "$UNAME_RELEASE" | sed -e 's/[-(].*//'`
GUESS=$UNAME_MACHINE-unknown-$GNU_SYS$GNU_REL-$LIBC
;;
x86_64:[Mm]anagarm:*:*|i?86:[Mm]anagarm:*:*)
GUESS="$UNAME_MACHINE-pc-managarm-mlibc"
;;
*:[Mm]anagarm:*:*)
GUESS="$UNAME_MACHINE-unknown-managarm-mlibc"
;;
*:Minix:*:*)
GUESS=$UNAME_MACHINE-unknown-minix
;;
@ -1036,7 +1042,7 @@ EOF
k1om:Linux:*:*)
GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
;;
loongarch32:Linux:*:* | loongarch64:Linux:*:* | loongarchx32:Linux:*:*)
loongarch32:Linux:*:* | loongarch64:Linux:*:*)
GUESS=$UNAME_MACHINE-unknown-linux-$LIBC
;;
m32r*:Linux:*:*)
@ -1191,7 +1197,7 @@ EOF
GUESS=$UNAME_MACHINE-pc-sysv4.2uw$UNAME_VERSION
;;
i*86:OS/2:*:*)
# If we were able to find `uname', then EMX Unix compatibility
# If we were able to find 'uname', then EMX Unix compatibility
# is probably installed.
GUESS=$UNAME_MACHINE-pc-os2-emx
;;
@ -1332,7 +1338,7 @@ EOF
GUESS=ns32k-sni-sysv
fi
;;
PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
PENTIUM:*:4.0*:*) # Unisys 'ClearPath HMP IX 4000' SVR4/MP effort
# says <Richard.M.Bartel@ccMail.Census.GOV>
GUESS=i586-unisys-sysv4
;;

49
exec/config.sub vendored
View file

@ -1,10 +1,10 @@
#!/usr/bin/sh
# Configuration validation subroutine script.
# Copyright 1992-2022 Free Software Foundation, Inc.
# Copyright 1992-2023 Free Software Foundation, Inc.
# shellcheck disable=SC2006,SC2268 # see below for rationale
timestamp='2022-01-03'
timestamp='2023-06-23'
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
@ -76,13 +76,13 @@ Report bugs and patches to <config-patches@gnu.org>."
version="\
GNU config.sub ($timestamp)
Copyright 1992-2022 Free Software Foundation, Inc.
Copyright 1992-2023 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
help="
Try \`$me --help' for more information."
Try '$me --help' for more information."
# Parse command line
while test $# -gt 0 ; do
@ -130,7 +130,7 @@ IFS=$saved_IFS
# Separate into logical components for further validation
case $1 in
*-*-*-*-*)
echo Invalid configuration \`"$1"\': more than four components >&2
echo "Invalid configuration '$1': more than four components" >&2
exit 1
;;
*-*-*-*)
@ -145,7 +145,7 @@ case $1 in
nto-qnx* | linux-* | uclinux-uclibc* \
| uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \
| netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \
| storm-chaos* | os2-emx* | rtmk-nova*)
| storm-chaos* | os2-emx* | rtmk-nova* | managarm-*)
basic_machine=$field1
basic_os=$maybe_os
;;
@ -943,7 +943,7 @@ $basic_machine
EOF
IFS=$saved_IFS
;;
# We use `pc' rather than `unknown'
# We use 'pc' rather than 'unknown'
# because (1) that's what they normally are, and
# (2) the word "unknown" tends to confuse beginning users.
i*86 | x86_64)
@ -1075,7 +1075,7 @@ case $cpu-$vendor in
pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*)
cpu=i586
;;
pentiumpro-* | p6-* | 6x86-* | athlon-* | athalon_*-*)
pentiumpro-* | p6-* | 6x86-* | athlon-* | athlon_*-*)
cpu=i686
;;
pentiumii-* | pentium2-* | pentiumiii-* | pentium3-*)
@ -1207,7 +1207,7 @@ case $cpu-$vendor in
| k1om \
| le32 | le64 \
| lm32 \
| loongarch32 | loongarch64 | loongarchx32 \
| loongarch32 | loongarch64 \
| m32c | m32r | m32rle \
| m5200 | m68000 | m680[012346]0 | m68360 | m683?2 | m68k \
| m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x \
@ -1285,7 +1285,7 @@ case $cpu-$vendor in
;;
*)
echo Invalid configuration \`"$1"\': machine \`"$cpu-$vendor"\' not recognized 1>&2
echo "Invalid configuration '$1': machine '$cpu-$vendor' not recognized" 1>&2
exit 1
;;
esac
@ -1341,6 +1341,10 @@ EOF
kernel=linux
os=`echo "$basic_os" | sed -e 's|linux|gnu|'`
;;
managarm*)
kernel=managarm
os=`echo "$basic_os" | sed -e 's|managarm|mlibc|'`
;;
*)
kernel=
os=$basic_os
@ -1754,7 +1758,7 @@ case $os in
| onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \
| midnightbsd* | amdhsa* | unleashed* | emscripten* | wasi* \
| nsk* | powerunix* | genode* | zvmoe* | qnx* | emx* | zephyr* \
| fiwix* )
| fiwix* | mlibc* )
;;
# This one is extra strict with allowed versions
sco3.2v2 | sco3.2v[4-9]* | sco5v6*)
@ -1762,8 +1766,11 @@ case $os in
;;
none)
;;
kernel* )
# Restricted further below
;;
*)
echo Invalid configuration \`"$1"\': OS \`"$os"\' not recognized 1>&2
echo "Invalid configuration '$1': OS '$os' not recognized" 1>&2
exit 1
;;
esac
@ -1772,14 +1779,24 @@ esac
# (given a valid OS), if there is a kernel.
case $kernel-$os in
linux-gnu* | linux-dietlibc* | linux-android* | linux-newlib* \
| linux-musl* | linux-relibc* | linux-uclibc* )
| linux-musl* | linux-relibc* | linux-uclibc* | linux-mlibc* )
;;
uclinux-uclibc* )
;;
-dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* )
managarm-mlibc* | managarm-kernel* )
;;
-dietlibc* | -newlib* | -musl* | -relibc* | -uclibc* | -mlibc* )
# These are just libc implementations, not actual OSes, and thus
# require a kernel.
echo "Invalid configuration \`$1': libc \`$os' needs explicit kernel." 1>&2
echo "Invalid configuration '$1': libc '$os' needs explicit kernel." 1>&2
exit 1
;;
-kernel* )
echo "Invalid configuration '$1': '$os' needs explicit kernel." 1>&2
exit 1
;;
*-kernel* )
echo "Invalid configuration '$1': '$kernel' does not support '$os'." 1>&2
exit 1
;;
kfreebsd*-gnu* | kopensolaris*-gnu*)
@ -1796,7 +1813,7 @@ case $kernel-$os in
# Blank kernel with real OS is always fine.
;;
*-*)
echo "Invalid configuration \`$1': Kernel \`$kernel' not known to work with OS \`$os'." 1>&2
echo "Invalid configuration '$1': Kernel '$kernel' not known to work with OS '$os'." 1>&2
exit 1
;;
esac

3
java/org/gnu/emacs/EmacsOpenActivity.java
View file

@ -533,8 +533,7 @@ private class EmacsClientThread extends Thread
else
uri = intent.getParcelableExtra (Intent.EXTRA_STREAM);
if (uri != null
&& (scheme = uri.getScheme ()) != null
if ((scheme = uri.getScheme ()) != null
&& scheme.equals ("content"))
{
tem1 = EmacsService.buildContentName (uri);

3
java/org/gnu/emacs/EmacsSafThread.java
View file

@ -1430,9 +1430,6 @@ type is either NULL (in which case id should also be NULL) or
/* If so, don't check for FLAG_SUPPORTS_WRITE.
Check for FLAG_DIR_SUPPORTS_CREATE instead. */
if (!writable)
return 0;
index = cursor.getColumnIndex (Document.COLUMN_FLAGS);
if (index < 0)
return -3;

2
java/org/gnu/emacs/EmacsService.java
View file

@ -1413,7 +1413,7 @@ else if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.M)
of OperationCanceledException, SecurityException,
FileNotFoundException, or UnsupportedOperationException. */
private int
public int
documentIdFromName (String tree_uri, String name, String[] id_return)
{
/* Start the thread used to run SAF requests if it isn't already

95
lisp/calc/calc-units.el
View file

@ -43,11 +43,12 @@
;;; Measures, by François Cardarelli)
;;; All conversions are exact unless otherwise noted.
;; CODATA values updated February 2016, using 2014 adjustment
;; https://arxiv.org/pdf/1507.07956.pdf
;; Updated November 2018 for the redefinition of the SI
;; https://www.bipm.org/utils/en/pdf/CGPM/Draft-Resolution-A-EN.pdf
;; https://www.bipm.org/en/committees/cg/cgpm/26-2018/resolution-1
;; CODATA values last updated November 2023, using 2018 adjustment:
;; E. Tiesinga, P. J. Mohr, D. B. Newell, and B. N. Taylor,
;; Rev. Mod. Phys. 93, 025010 (2021)
(defvar math-standard-units
'( ;; Length
@ -122,7 +123,6 @@
( mph "mi/hr" "*Miles per hour" )
( kph "km/hr" "Kilometers per hour" )
( knot "nmi/hr" "Knot" )
( c "299792458 m/s" "Speed of light" ) ;; SI definition
;; Acceleration
( ga "980665*10^(-5) m/s^2" "*\"g\" acceleration" nil
@ -143,8 +143,8 @@
"31.10347680 g") ;; ESUWM, 1/12 exact value for lbt
( ct "(2/10) g" "Carat" nil
"0.2 g") ;; ESUWM
( u "1.660539040*10^(-27) kg" "Unified atomic mass" nil
"1.660539040 10^-27 kg (*)");;(approx) CODATA
( u "1.66053906660*10^(-27) kg" "Unified atomic mass" nil
"1.66053906660 10^-27 kg (*)") ;; (approx) CODATA
;; Force
( N "m kg/s^2" "*Newton" )
@ -210,9 +210,6 @@
( A nil "*Ampere" )
( C "A s" "Coulomb" )
( Fdy "ech Nav" "Faraday" )
( e "ech" "Elementary charge" )
( ech "1.602176634*10^(-19) C" "Elementary charge" nil
"1.602176634 10^-19 C") ;; SI definition
( V "W/A" "Volt" )
( ohm "V/A" "Ohm" )
( Ω "ohm" "Ohm" )
@ -259,53 +256,61 @@
;; Solid angle
( sr nil "*Steradian" )
;; Constants defining the International System of Units (SI)
( c "299792458 m/s" "*Speed of light" )
( h "6.62607015*10^(-34) J s" "Planck constant" nil
"6.62607015 10^-34 J s")
( ech "1.602176634*10^(-19) C" "Elementary charge" nil
"1.602176634 10^-19 C")
( e "ech" "Elementary charge" nil
"1.602176634 10^-19 C")
( k "1.380649*10^(-23) J/K" "Boltzmann constant" nil
"1.380649 10^-23 J/K")
( Nav "6.02214076*10^(23) / mol" "Avogadro constant" nil
"6.02214076 10^23 / mol")
;; Other physical quantities
;; Unless otherwise mentioned, the values are from CODATA,
;; and are approximate.
( h "6.62607015*10^(-34) J s" "*Planck's constant" nil
"6.62607015 10^-34 J s") ;; SI definition
( hbar "h / (2 pi)" "Planck's constant" ) ;; Exact
( hbar "h / (2 pi)" "*Reduced Planck constant" )
;; After the 2018 SI redefinition, eps0 and mu0 are measured quantities,
;; and mu0 no longer has the previous exact value of 4 pi 10^(-7) H/m.
( eps0 "ech^2 / (2 alpha h c)" "Permittivity of vacuum" )
( ε0 "eps0" "Permittivity of vacuum" )
( mu0 "1 / (eps0 c^2)" "Permeability of vacuum")
( μ0 "mu0" "Permeability of vacuum")
( G "6.67408*10^(-11) m^3/(kg s^2)" "Gravitational constant" nil
"6.67408 10^-11 m^3/(kg s^2) (*)")
( Nav "6.02214076*10^(23) / mol" "Avogadro's constant" nil
"6.02214076 10^23 / mol") ;; SI definition
( me "9.10938356*10^(-31) kg" "Electron rest mass" nil
"9.10938356 10^-31 kg (*)")
( mp "1.672621898*10^(-27) kg" "Proton rest mass" nil
"1.672621898 10^-27 kg (*)")
( mn "1.674927471*10^(-27) kg" "Neutron rest mass" nil
"1.674927471 10^-27 kg (*)")
( mmu "1.883531594*10^(-28) kg" "Muon rest mass" nil
"1.883531594 10^-28 kg (*)")
( G "6.67430*10^(-11) m^3/(kg s^2)" "Gravitational constant" nil
"6.67430 10^-11 m^3/(kg s^2) (*)")
( me "9.1093837015*10^(-31) kg" "Electron rest mass" nil
"9.1093837015 10^-31 kg (*)")
( mp "1.67262192369*10^(-27) kg" "Proton rest mass" nil
"1.67262192369 10^-27 kg (*)")
( mn "1.67492749804*10^(-27) kg" "Neutron rest mass" nil
"1.67492749804 10^-27 kg (*)")
( mmu "1.883531627*10^(-28) kg" "Muon rest mass" nil
"1.883531627 10^-28 kg (*)")
( mμ "mmu" "Muon rest mass" nil
"1.883531594 10^-28 kg (*)")
( Ryd "10973731.568508 /m" "Rydberg's constant" nil
"10973731.568508 /m (*)")
( k "1.380649*10^(-23) J/K" "Boltzmann's constant" nil
"1.380649 10^-23 J/K") ;; SI definition
"1.883531627 10^-28 kg (*)")
( Ryd "10973731.568160 /m" "Rydberg constant" nil
"10973731.568160 /m (*)")
( sigma "2 pi^5 k^4 / (15 h^3 c^2)" "Stefan-Boltzmann constant")
( σ "sigma" "Stefan-Boltzmann constant")
( alpha "7.2973525664*10^(-3)" "Fine structure constant" nil
"7.2973525664 10^-3 (*)")
( α "alpha" "Fine structure constant" nil
"7.2973525664 10^-3 (*)")
( muB "927.4009994*10^(-26) J/T" "Bohr magneton" nil
"927.4009994 10^-26 J/T (*)")
( muN "5.050783699*10^(-27) J/T" "Nuclear magneton" nil
"5.050783699 10^-27 J/T (*)")
( mue "-928.4764620*10^(-26) J/T" "Electron magnetic moment" nil
"-928.4764620 10^-26 J/T (*)")
( mup "1.4106067873*10^(-26) J/T" "Proton magnetic moment" nil
"1.4106067873 10^-26 J/T (*)")
( R0 "Nav k" "Molar gas constant") ;; Exact
( V0 "22.710947*10^(-3) m^3/mol" "Standard volume of ideal gas" nil
"22.710947 10^-3 m^3/mol (*)")
( alpha "7.2973525693*10^(-3)" "Fine structure constant" nil
"7.2973525693 10^-3 (*)")
( α "alpha" "Fine structure constant" nil
"7.2973525693 10^-3 (*)")
( muB "9.2740100783*10^(-24) J/T" "Bohr magneton" nil
"9.2740100783 10^-24 J/T (*)")
( muN "5.0507837461*10^(-27) J/T" "Nuclear magneton" nil
"5.0507837461 10^-27 J/T (*)")
( mue "-9.2847647043*10^(-24) J/T" "Electron magnetic moment" nil
"-9.2847647043 10^-24 J/T (*)")
( mup "1.41060679736*10^(-26) J/T" "Proton magnetic moment" nil
"1.41060679736 10^-26 J/T (*)")
( R0 "Nav k" "Molar gas constant" )
( V0 "R0 273.15 K / 10^5 Pa" "Standard volume of ideal gas" )
;; IUPAC 1982 standard temperature and pressure
;; Logarithmic units
( Np nil "*Neper")
( dB "(ln(10)/20) Np" "decibel"))

246
lisp/completion-preview.el
View file

@ -22,10 +22,11 @@
;;; Commentary:
;; This library provides the Completion Preview mode. This minor mode
;; displays the top completion candidate for the symbol at point in an
;; displays a completion suggestion for the symbol at point in an
;; overlay after point. Check out the customization group
;; `completion-preview' for user options that you may want to tweak.
;;
;; To enable Completion Preview mode, use `completion-preview-mode'.
;; To accept the completion suggestion, press TAB. If you want to
;; ignore a completion suggestion, just go on editing or moving around
;; the buffer. Completion Preview mode continues to update the
@ -48,15 +49,6 @@
;; that should appear around point for Emacs to suggest a completion.
;; By default, this option is set to 3, so Emacs suggests a completion
;; if you type "foo", but typing just "fo" doesn't show the preview.
;;
;; The user option `completion-preview-insert-on-completion' controls
;; what happens when you invoke `completion-at-point' while the
;; completion preview is visible. By default this option is nil,
;; which tells `completion-at-point' to ignore the completion preview
;; and show the list of completion candidates as usual. If you set
;; `completion-preview-insert-on-completion' to non-nil, then
;; `completion-at-point' inserts the preview directly without looking
;; for more candidates.
;;; Code:
@ -91,9 +83,20 @@ first candidate, and you can cycle between the candidates with
:type 'natnum
:version "30.1")
(defcustom completion-preview-insert-on-completion nil
"Whether \\[completion-at-point] inserts the previewed suggestion."
:type 'boolean
(defcustom completion-preview-message-format
"Completion suggestion %i out of %n"
"Message to show after cycling the completion preview suggestion.
If the value is a string, `completion-preview-next-candidate' and
`completion-preview-prev-candidate' display this string in the
echo area, after substituting \"%i\" with the 1-based index of
the completion suggestion that the preview is showing, and \"%n\"
with the total number of available completion suggestions for the
text around point.
If this option is nil, these commands do not display any message."
:type '(choice (string :tag "Message format")
(const :tag "No message" nil))
:version "30.1")
(defvar completion-preview-sort-function #'minibuffer--sort-by-length-alpha
@ -113,6 +116,11 @@ first candidate, and you can cycle between the candidates with
"Face for exact completion preview overlay."
:version "30.1")
(defface completion-preview-highlight
'((t :inherit highlight))
"Face for highlighting the completion preview when the mouse is over it."
:version "30.1")
(defvar-keymap completion-preview-active-mode-map
:doc "Keymap for Completion Preview Active mode."
"C-i" #'completion-preview-insert
@ -120,11 +128,26 @@ first candidate, and you can cycle between the candidates with
;; "M-p" #'completion-preview-prev-candidate
)
(defvar-keymap completion-preview--mouse-map
:doc "Keymap for mouse clicks on the completion preview."
"<down-mouse-1>" #'completion-preview-insert
"C-<down-mouse-1>" #'completion-at-point
"<down-mouse-2>" #'completion-at-point
(format "<%s>" mouse-wheel-up-event) #'completion-preview-prev-candidate
(format "<%s>" mouse-wheel-up-alternate-event) #'completion-preview-prev-candidate
(format "<%s>" mouse-wheel-down-event) #'completion-preview-next-candidate
(format "<%s>" mouse-wheel-down-alternate-event) #'completion-preview-next-candidate)
(defvar-local completion-preview--overlay nil)
(defvar completion-preview--internal-commands
'(completion-preview-next-candidate completion-preview-prev-candidate)
"List of commands that manipulate the completion preview.")
'(completion-preview-next-candidate
completion-preview-prev-candidate
;; Don't dismiss or update the preview when the user scrolls.
mwheel-scroll)
"List of commands that manipulate the completion preview.
Completion Preview mode avoids updating the preview after these commands.")
(defsubst completion-preview--internal-command-p ()
"Return non-nil if `this-command' manipulates the completion preview."
@ -149,77 +172,96 @@ first candidate, and you can cycle between the candidates with
(setq completion-preview--overlay nil)))
(defun completion-preview--make-overlay (pos string)
"Make a new completion preview overlay at POS showing STRING."
"Make preview overlay showing STRING at POS, or move existing preview there."
(if completion-preview--overlay
(move-overlay completion-preview--overlay pos pos)
(setq completion-preview--overlay (make-overlay pos pos))
(overlay-put completion-preview--overlay 'window (selected-window)))
(let ((previous (overlay-get completion-preview--overlay 'after-string)))
(unless (and previous (string= previous string))
(unless (and previous (string= previous string)
(eq (get-text-property 0 'face previous)
(get-text-property 0 'face string)))
(add-text-properties 0 1 '(cursor 1) string)
(overlay-put completion-preview--overlay 'after-string string))
completion-preview--overlay))
(defun completion-preview--get (prop)
(defsubst completion-preview--get (prop)
"Return property PROP of the completion preview overlay."
(overlay-get completion-preview--overlay prop))
(define-minor-mode completion-preview-active-mode
"Mode for when the completion preview is shown."
:interactive nil
(if completion-preview-active-mode
(add-hook 'completion-at-point-functions #'completion-preview--insert -1 t)
(remove-hook 'completion-at-point-functions #'completion-preview--insert t)
(completion-preview-hide)))
(unless completion-preview-active-mode (completion-preview-hide)))
(defun completion-preview--exit-function (func)
"Return an exit function that hides the completion preview and calls FUNC."
(lambda (&rest args)
(completion-preview-active-mode -1)
(when (functionp func) (apply func args))))
(defun completion-preview--try-table (table beg end props)
"Check TABLE for a completion matching the text between BEG and END.
PROPS is a property list with additional information about TABLE.
See `completion-at-point-functions' for more details.
If TABLE contains a matching completion, return a list
\(PREVIEW BEG END ALL BASE EXIT-FN) where PREVIEW is the text to
show in the completion preview, ALL is the list of all matching
completion candidates, BASE is a common prefix that TABLE elided
from the start of each candidate, and EXIT-FN is either a
function to call after inserting PREVIEW or nil. If TABLE does
not contain matching completions, or if there are multiple
matching completions and `completion-preview-exact-match-only' is
non-nil, return nil instead."
(let* ((pred (plist-get props :predicate))
(exit-fn (plist-get props :exit-function))
(string (buffer-substring beg end))
(md (completion-metadata string table pred))
(sort-fn (or (completion-metadata-get md 'cycle-sort-function)
(completion-metadata-get md 'display-sort-function)
completion-preview-sort-function))
(all (let ((completion-lazy-hilit t))
(completion-all-completions string table pred
(- (point) beg) md)))
(last (last all))
(base (or (cdr last) 0))
(prefix (substring string base)))
(when last
(setcdr last nil)
(when-let ((sorted (funcall sort-fn
(delete prefix (all-completions prefix all)))))
(unless (and (cdr sorted) completion-preview-exact-match-only)
(list (propertize (substring (car sorted) (length prefix))
'face (if (cdr sorted)
'completion-preview
'completion-preview-exact)
'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map)
(+ beg base) end sorted
(substring string 0 base) exit-fn))))))
(defun completion-preview--capf-wrapper (capf)
"Translate return value of CAPF to properties for completion preview overlay."
(let ((res (ignore-errors (funcall capf))))
(and (consp res)
(not (functionp res))
(seq-let (beg end table &rest plist) res
(or (completion-preview--try-table table beg end plist)
(unless (eq 'no (plist-get plist :exclusive))
;; Return non-nil to exclude other capfs.
'(nil)))))))
(defun completion-preview--update ()
"Update completion preview."
(seq-let (beg end table &rest plist)
(let ((completion-preview-insert-on-completion nil))
(run-hook-with-args-until-success 'completion-at-point-functions))
(when (and beg end table)
(let* ((pred (plist-get plist :predicate))
(exit-fn (completion-preview--exit-function
(plist-get plist :exit-function)))
(string (buffer-substring beg end))
(md (completion-metadata string table pred))
(sort-fn (or (completion-metadata-get md 'cycle-sort-function)
(completion-metadata-get md 'display-sort-function)
completion-preview-sort-function))
(all (let ((completion-lazy-hilit t))
(completion-all-completions string table pred
(- (point) beg) md)))
(last (last all))
(base (or (cdr last) 0))
(bbeg (+ beg base))
(prefix (substring string base)))
(when last
(setcdr last nil)
(let* ((filtered (remove prefix (all-completions prefix all)))
(sorted (funcall sort-fn filtered))
(multi (cadr sorted)) ; multiple candidates
(cand (car sorted)))
(when (and cand
(not (and multi
completion-preview-exact-match-only)))
(let* ((face (if multi
'completion-preview
'completion-preview-exact))
(after (propertize (substring cand (length prefix))
'face face))
(ov (completion-preview--make-overlay end after)))
(overlay-put ov 'completion-preview-beg bbeg)
(overlay-put ov 'completion-preview-end end)
(overlay-put ov 'completion-preview-index 0)
(overlay-put ov 'completion-preview-cands sorted)
(overlay-put ov 'completion-preview-exit-fn exit-fn)
(completion-preview-active-mode)))))))))
(seq-let (preview beg end all base exit-fn)
(run-hook-wrapped
'completion-at-point-functions
#'completion-preview--capf-wrapper)
(when preview
(let ((ov (completion-preview--make-overlay end preview)))
(overlay-put ov 'completion-preview-beg beg)
(overlay-put ov 'completion-preview-end end)
(overlay-put ov 'completion-preview-index 0)
(overlay-put ov 'completion-preview-cands all)
(overlay-put ov 'completion-preview-base base)
(overlay-put ov 'completion-preview-exit-fn exit-fn)
(completion-preview-active-mode)))))
(defun completion-preview--show ()
"Show a new completion preview.
@ -251,7 +293,9 @@ point, otherwise hide it."
;; The previous preview is still applicable, update it.
(overlay-put (completion-preview--make-overlay
cur (propertize (substring cand (- cur beg))
'face face))
'face face
'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map))
'completion-preview-end cur)
;; The previous preview is no longer applicable, hide it.
(completion-preview-active-mode -1))))
@ -271,35 +315,30 @@ point, otherwise hide it."
(completion-preview--show))
(completion-preview-active-mode -1)))
(defun completion-preview--insert ()
"Completion at point function for inserting the current preview.
When `completion-preview-insert-on-completion' is nil, this
function returns nil. Completion Preview mode adds this function
to `completion-at-point-functions' when the preview is shown,
such that `completion-at-point' inserts the preview candidate if
and only if `completion-preview-insert-on-completion' is non-nil."
(when (and completion-preview-active-mode
completion-preview-insert-on-completion)
(list (completion-preview--get 'completion-preview-beg)
(completion-preview--get 'completion-preview-end)
(list (nth (completion-preview--get 'completion-preview-index)
(completion-preview--get 'completion-preview-cands)))
:exit-function (completion-preview--get 'completion-preview-exit-fn))))
(defun completion-preview-insert ()
"Insert the completion candidate that the preview shows."
"Insert the completion candidate that the preview is showing."
(interactive)
(let ((completion-preview-insert-on-completion t))
(completion-at-point)))
(if completion-preview-active-mode
(let* ((pre (completion-preview--get 'completion-preview-base))
(end (completion-preview--get 'completion-preview-end))
(ind (completion-preview--get 'completion-preview-index))
(all (completion-preview--get 'completion-preview-cands))
(efn (completion-preview--get 'completion-preview-exit-fn))
(aft (completion-preview--get 'after-string))
(str (concat pre (nth ind all))))
(completion-preview-active-mode -1)
(goto-char end)
(insert (substring-no-properties aft))
(when (functionp efn) (funcall efn str 'finished)))
(user-error "No current completion preview")))
(defun completion-preview-prev-candidate ()
"Cycle the candidate that the preview shows to the previous suggestion."
"Cycle the candidate that the preview is showing to the previous suggestion."
(interactive)
(completion-preview-next-candidate -1))
(defun completion-preview-next-candidate (direction)
"Cycle the candidate that the preview shows in direction DIRECTION.
"Cycle the candidate that the preview is showing in direction DIRECTION.
DIRECTION should be either 1 which means cycle forward, or -1
which means cycle backward. Interactively, DIRECTION is the
@ -319,14 +358,37 @@ prefix argument and defaults to 1."
(let ((aft (propertize (substring str (- pos beg))
'face (if (< 1 len)
'completion-preview
'completion-preview-exact))))
'completion-preview-exact)
'mouse-face 'completion-preview-highlight
'keymap completion-preview--mouse-map)))
(add-text-properties 0 1 '(cursor 1) aft)
(overlay-put completion-preview--overlay 'completion-preview-index new)
(overlay-put completion-preview--overlay 'after-string aft)))))
(overlay-put completion-preview--overlay 'after-string aft))
(when completion-preview-message-format
(message (format-spec completion-preview-message-format
`((?i . ,(1+ new)) (?n . ,len))))))))
(defun completion-preview--active-p (_symbol buffer)
"Check if the completion preview is currently shown in BUFFER."
(buffer-local-value 'completion-preview-active-mode buffer))
(dolist (cmd '(completion-preview-insert
completion-preview-prev-candidate
completion-preview-next-candidate))
(put cmd 'completion-predicate #'completion-preview--active-p))
;;;###autoload
(define-minor-mode completion-preview-mode
"Show in-buffer completion preview as you type."
"Show in-buffer completion suggestions in a preview as you type.
This mode automatically shows and updates the completion preview
according to the text around point.
\\<completion-preview-active-mode-map>\
When the preview is visible, \\[completion-preview-insert]
accepts the completion suggestion,
\\[completion-preview-next-candidate] cycles forward to the next
completion suggestion, and \\[completion-preview-prev-candidate]
cycles backward."
:lighter " CP"
(if completion-preview-mode
(add-hook 'post-command-hook #'completion-preview--post-command nil t)

114
lisp/dired-aux.el
View file

@ -763,22 +763,6 @@ with a prefix argument."
;;; Shell commands
(declare-function mailcap-file-default-commands "mailcap" (files))
(defvar dired-aux-files)
(defun dired-minibuffer-default-add-shell-commands ()
"Return a list of all commands associated with current Dired files.
This function is used to add all related commands retrieved by `mailcap'
to the end of the list of defaults just after the default value."
(interactive)
(let ((commands (and (boundp 'dired-aux-files)
(require 'mailcap nil t)
(mailcap-file-default-commands dired-aux-files))))
(if (listp minibuffer-default)
(append minibuffer-default commands)
(cons minibuffer-default commands))))
;; This is an extra function so that you can redefine it, e.g., to use gmhist.
(defun dired-read-shell-command (prompt arg files)
"Read a Dired shell command.
@ -789,14 +773,9 @@ file names. The result is used as the prompt.
Use `dired-guess-shell-command' to offer a smarter default choice
of shell command."
(minibuffer-with-setup-hook
(lambda ()
(setq-local dired-aux-files files)
(setq-local minibuffer-default-add-function
#'dired-minibuffer-default-add-shell-commands))
(setq prompt (format prompt (dired-mark-prompt arg files)))
(dired-mark-pop-up nil 'shell files
'dired-guess-shell-command prompt files)))
(setq prompt (format prompt (dired-mark-prompt arg files)))
(dired-mark-pop-up nil 'shell files
'dired-guess-shell-command prompt files))
;;;###autoload
(defcustom dired-confirm-shell-command t
@ -1316,7 +1295,7 @@ See `dired-guess-shell-alist-user'."
;;;###autoload
(defun dired-guess-shell-command (prompt files)
"Ask user with PROMPT for a shell command, guessing a default from FILES."
(let ((default (dired-guess-default files))
(let ((default (shell-command-guess files))
default-list val)
(if (null default)
;; Nothing to guess
@ -1340,6 +1319,88 @@ See `dired-guess-shell-alist-user'."
;; If we got a return, then return default.
(if (equal val "") default val))))
(defcustom shell-command-guess-functions
'(shell-command-guess-dired)
"List of functions that guess shell commands for files.
Each function receives a list of commands and a list of file names
and should return the same list of commands with changes
such as added new commands."
:type '(repeat
(choice (function-item shell-command-guess-dired)
(function-item shell-command-guess-mailcap)
(function-item shell-command-guess-xdg)
(function-item shell-command-guess-open)
(function :tag "Custom function")))
:group 'dired
:version "30.1")
(defun shell-command-guess (files)
"Return a list of shell commands, appropriate for FILES.
The list is populated by calling functions from
`shell-command-guess-functions'. Each function receives the list
of commands and the list of file names and returns the same list
after adding own commands to the composite list."
(let ((commands nil))
(run-hook-wrapped 'shell-command-guess-functions
(lambda (fun)
(setq commands (funcall fun commands files))
nil))
commands))
(defun shell-command-guess-dired (commands files)
"Populate COMMANDS using `dired-guess-default'."
(append (ensure-list (dired-guess-default files)) commands))
(declare-function mailcap-file-default-commands "mailcap" (files))
(defun shell-command-guess-mailcap (commands files)
"Populate COMMANDS by MIME types of FILES."
(require 'mailcap)
(append (mailcap-file-default-commands files) commands))
(declare-function xdg-mime-apps "xdg" (mime))
(declare-function xdg-desktop-read-file "xdg" (filename &optional group))
(defun shell-command-guess-xdg (commands files)
"Populate COMMANDS by XDG configuration for FILES."
(require 'xdg)
(let* ((xdg-mime (when (executable-find "xdg-mime")
(string-trim-right
(shell-command-to-string
(concat "xdg-mime query filetype " (car files))))))
(xdg-mime-apps (unless (string-empty-p xdg-mime)
(xdg-mime-apps xdg-mime)))
(xdg-commands
(mapcar (lambda (desktop)
(setq desktop (xdg-desktop-read-file desktop))
(propertize
(replace-regexp-in-string
" .*" "" (gethash "Exec" desktop))
'name (gethash "Name" desktop)))
xdg-mime-apps)))
(append xdg-commands commands)))
(defcustom shell-command-guess-open
(cond
((executable-find "xdg-open")
"xdg-open")
((memq system-type '(gnu/linux darwin))
"open")
((memq system-type '(windows-nt ms-dos))
"start")
((eq system-type 'cygwin)
"cygstart")
((executable-find "run-mailcap")
"run-mailcap"))
"A shell command to open a file externally."
:type 'string
:group 'dired
:version "30.1")
(defun shell-command-guess-open (commands _files)
"Populate COMMANDS by the `open' command."
(append (ensure-list shell-command-guess-open) commands))
;;; Commands that delete or redisplay part of the dired buffer
@ -3856,9 +3917,6 @@ case, the VERBOSE argument is ignored."
(setq model (vc-checkout-model backend only-files-list))))
(list backend files only-files-list state model)))
(define-obsolete-function-alias 'minibuffer-default-add-dired-shell-commands
#'dired-minibuffer-default-add-shell-commands "29.1")
(provide 'dired-aux)

176
lisp/dired.el
View file

@ -350,6 +350,7 @@ with the buffer narrowed to the listing."
(defcustom dired-make-directory-clickable t
"When non-nil, make the directory at the start of the dired buffer clickable."
:version "29.1"
:group 'dired
:type 'boolean)
(defcustom dired-initial-position-hook nil
@ -429,6 +430,7 @@ is anywhere on its Dired line, except the beginning of the line."
(defcustom dired-kill-when-opening-new-dired-buffer nil
"If non-nil, kill the current buffer when selecting a new directory."
:type 'boolean
:group 'dired
:version "28.1")
(defcustom dired-guess-shell-case-fold-search t
@ -516,6 +518,22 @@ Possible non-nil values:
(defcustom dired-hide-details-preserved-columns nil
"List of columns which are not hidden in `dired-hide-details-mode'."
:type '(repeat integer)
:group 'dired
:version "30.1")
(defcustom dired-filename-display-length nil
"If non-nil, restrict the display length of filenames.
If the value is the symbol `window', the right edge of current
window is used as the restriction. Otherwise, it should be an
integer representing the maximum filename length.
The middle part of filename whose length exceeds the restriction
is hidden by using the `invisible' property and an ellipsis is
displayed instead."
:type '(choice (const :tag "No restriction" nil)
(const :tag "Window" window)
(integer :tag "Integer"))
:group 'dired
:version "30.1")
@ -1901,51 +1919,72 @@ other marked file as well. Otherwise, unmark all files."
(defvar dired-click-to-select-map)
(defun dired-insert-set-properties (beg end)
"Add various text properties to the lines in the region, from BEG to END."
"Add various text properties to the lines in the region, from BEG to END.
Overlays could be added when some user options are enabled, e.g.,
`dired-filename-display-length'."
(remove-overlays beg end 'invisible 'dired-filename-hide)
(save-excursion
(goto-char beg)
(while (< (point) end)
(ignore-errors
(if (not (dired-move-to-filename))
(unless (or (looking-at-p "^$")
(looking-at-p dired-subdir-regexp))
(put-text-property (line-beginning-position)
(1+ (line-end-position))
'invisible 'dired-hide-details-information))
(save-excursion
(let ((end (1- (point)))
(opoint (goto-char (1+ (pos-bol))))
(i 0))
(put-text-property opoint end 'invisible 'dired-hide-details-detail)
(while (re-search-forward "[^ ]+" end t)
(when (member (cl-incf i) dired-hide-details-preserved-columns)
(put-text-property opoint (point) 'invisible nil))
(setq opoint (point)))))
(let ((beg (point)) (end (save-excursion
(dired-move-to-end-of-filename)
(1- (point)))))
(if dired-click-to-select-mode
(put-text-property beg end 'keymap
dired-click-to-select-map)
(when (and dired-mouse-drag-files (fboundp 'x-begin-drag))
(put-text-property beg end 'keymap
dired-mouse-drag-files-map)))
(add-text-properties
beg (1+ end)
`(mouse-face
highlight
dired-filename t
help-echo ,(if dired-click-to-select-mode
"mouse-2: mark or unmark this file"
(if (and dired-mouse-drag-files
(fboundp 'x-begin-drag))
"down-mouse-1: drag this file to another program
(let ((ell-len (dired--get-ellipsis-length)) maxlen filename-col)
(while (< (point) end)
(ignore-errors
(if (not (dired-move-to-filename))
(unless (or (looking-at-p "^$")
(looking-at-p dired-subdir-regexp))
(put-text-property (line-beginning-position)
(1+ (line-end-position))
'invisible 'dired-hide-details-information))
(save-excursion
(let ((end (1- (point)))
(opoint (goto-char (1+ (pos-bol))))
(i 0))
(put-text-property opoint end 'invisible 'dired-hide-details-detail)
(while (re-search-forward "[^ ]+" end t)
(when (member (cl-incf i) dired-hide-details-preserved-columns)
(put-text-property opoint (point) 'invisible nil))
(setq opoint (point)))))
(let ((beg (point)) (end (save-excursion
(dired-move-to-end-of-filename)
(1- (point)))))
(if dired-click-to-select-mode
(put-text-property beg end 'keymap
dired-click-to-select-map)
(when (and dired-mouse-drag-files (fboundp 'x-begin-drag))
(put-text-property beg end 'keymap
dired-mouse-drag-files-map)))
(when dired-filename-display-length
(let ((len (string-width (buffer-substring beg (1+ end))))
ell-beg)
(or maxlen (setq maxlen (dired--get-filename-display-length)))
(when (and (integerp maxlen) (> len maxlen (+ ell-len 2)))
(or filename-col (setq filename-col (current-column)))
(move-to-column (+ filename-col (/ maxlen 2)))
(setq ell-beg (point))
(move-to-column (+ filename-col (/ maxlen 2)
(- len maxlen) ell-len))
;; Here we use overlays because isearch by default
;; doesn't support finding matches in hidden text
;; made invisible via text properties.
(let ((ov (make-overlay ell-beg (point))))
(overlay-put ov 'invisible 'dired-filename-hide)
(overlay-put ov 'isearch-open-invisible #'delete-overlay)
(overlay-put ov 'evaporate t)))))
(add-text-properties
beg (1+ end)
`(mouse-face
highlight
dired-filename t
help-echo ,(if dired-click-to-select-mode
"mouse-2: mark or unmark this file"
(if (and dired-mouse-drag-files
(fboundp 'x-begin-drag))
"down-mouse-1: drag this file to another program
mouse-2: visit this file in other window"
"mouse-2: visit this file in other window"))))
(when (< (+ end 5) (line-end-position))
(put-text-property (+ end 5) (line-end-position)
'invisible 'dired-hide-details-link)))))
(forward-line 1))))
"mouse-2: visit this file in other window"))))
(when (< (+ end 5) (line-end-position))
(put-text-property (+ end 5) (line-end-position)
'invisible 'dired-hide-details-link)))))
(forward-line 1)))))
(defun dired--make-directory-clickable ()
(save-excursion
@ -1977,6 +2016,28 @@ mouse-2: visit this file in other window"
"RET" click))))
(setq segment-start (point)))))))
(defun dired--get-ellipsis-length ()
"Return length of ellipsis."
(let* ((dt (or (window-display-table)
buffer-display-table
standard-display-table))
(glyphs (and dt (display-table-slot dt 'selective-display)))
(vlen (length glyphs))
(char-glyphs (make-vector vlen nil)))
(dotimes (i vlen)
(aset char-glyphs i (glyph-char (aref glyphs i))))
(string-width (if glyphs (concat char-glyphs) "..."))))
(defun dired--get-filename-display-length ()
"Return maximum display length of filename.
When `dired-filename-display-length' is not an integer, the
function actually returns the number of columns available for
displaying the file names, and should be called with point at the
first character of the file name."
(if (integerp dired-filename-display-length)
dired-filename-display-length
(- (window-max-chars-per-line) 1 (current-column))))
;;; Reverting a dired buffer
@ -2534,13 +2595,28 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST."
"Populate MENU with Dired mode commands at CLICK."
(when (mouse-posn-property (event-start click) 'dired-filename)
(define-key menu [dired-separator] menu-bar-separator)
(let ((easy-menu (make-sparse-keymap "Immediate")))
(let* ((filename (save-excursion
(mouse-set-point click)
(dired-get-filename nil t)))
(commands (shell-command-guess (list filename)))
(easy-menu (make-sparse-keymap "Immediate")))
(easy-menu-define nil easy-menu nil
'("Immediate"
`("Immediate"
["Find This File" dired-mouse-find-file
:help "Edit file at mouse click"]
["Find in Other Window" dired-mouse-find-file-other-window
:help "Edit file at mouse click in other window"]))
:help "Edit file at mouse click in other window"]
,@(when commands
(list (cons "Open With"
(append
(mapcar (lambda (command)
`[,(or (get-text-property 0 'name command)
command)
(lambda ()
(interactive)
(dired-do-async-shell-command
,command nil (list ,filename)))])
commands)))))))
(dolist (item (reverse (lookup-key easy-menu [menu-bar immediate])))
(when (consp item)
(define-key menu (vector (car item)) (cdr item))))))
@ -2618,6 +2694,7 @@ Keybindings:
mode-line-buffer-identification
(propertized-buffer-identification "%17b"))
(add-to-invisibility-spec '(dired . t))
(dired-filename-update-invisibility-spec)
;; Ignore dired-hide-details-* value of invisible text property by default.
(when (eq buffer-invisibility-spec t)
(setq buffer-invisibility-spec (list t)))
@ -3117,6 +3194,15 @@ See options: `dired-hide-details-hide-symlink-targets' and
;;; Functions to hide/unhide text
(defun dired-filename-update-invisibility-spec ()
"Update `buffer-invisibility-spec' for filenames.
Specifically, the filename invisibility spec is added in Dired
buffers and removed in WDired buffers."
(funcall (if (derived-mode-p 'dired-mode)
'add-to-invisibility-spec
'remove-from-invisibility-spec)
'(dired-filename-hide . t)))
(defun dired--find-hidden-pos (start end)
(text-property-any start end 'invisible 'dired))

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

@ -485,10 +485,6 @@ There can be multiple entries for the same NAME if it has several aliases.")
(`(,(pred byte-code-function-p) . ,exps)
(cons fn (mapcar #'byte-optimize-form exps)))
(`(,(pred (not symbolp)) . ,_)
(byte-compile-warn-x form "`%s' is a malformed function" fn)
form)
((guard (when for-effect
(if-let ((tmp (byte-opt--fget fn 'side-effect-free)))
(or byte-compile-delete-errors

270
lisp/emacs-lisp/bytecomp.el
View file

@ -2479,10 +2479,9 @@ Call from the source buffer."
(print-quoted t)
(print-gensym t)
(print-circle t)) ; Handle circular data structures.
(if (and (memq (car-safe form) '(defvar defvaralias defconst
autoload custom-declare-variable))
(stringp (nth 3 form)))
(byte-compile-output-docform nil nil '("\n(" 3 ")") form nil
(if (memq (car-safe form) '(defvar defvaralias defconst
autoload custom-declare-variable))
(byte-compile-output-docform nil nil nil '("\n(" ")") form nil 3 nil
(memq (car form)
'(defvaralias autoload
custom-declare-variable)))
@ -2492,10 +2491,105 @@ Call from the source buffer."
(defvar byte-compile--for-effect)
(defun byte-compile-output-docform (preface name info form specindex quoted)
"Print a form with a doc string. INFO is (prefix doc-index postfix).
If PREFACE and NAME are non-nil, print them too,
before INFO and the FORM but after the doc string itself.
(defun byte-compile--output-docform-recurse
(info position form cvecindex docindex specindex quoted)
"Print a form with a doc string. INFO is (prefix postfix).
POSITION is where the next doc string is to be inserted.
CVECINDEX is the index in the FORM of the constant vector, or nil.
DOCINDEX is the index of the doc string (or nil) in the FORM.
If SPECINDEX is non-nil, it is the index in FORM
of the function bytecode string. In that case,
we output that argument and the following argument
\(the constants vector) together, for lazy loading.
QUOTED says that we have to put a quote before the
list that represents a doc string reference.
`defvaralias', `autoload' and `custom-declare-variable' need that.
Return the position after any inserted docstrings as comments."
(let ((index 0)
doc-string-position)
;; Insert the doc string, and make it a comment with #@LENGTH.
(when (and byte-compile-dynamic-docstrings
(stringp (nth docindex form)))
(goto-char position)
(setq doc-string-position
(byte-compile-output-as-comment
(nth docindex form) nil)
position (point))
(goto-char (point-max)))
(insert (car info))
(prin1 (car form) byte-compile--outbuffer)
(while (setq form (cdr form))
(setq index (1+ index))
(insert " ")
(cond ((and (numberp specindex) (= index specindex)
;; Don't handle the definition dynamically
;; if it refers (or might refer)
;; to objects already output
;; (for instance, gensyms in the arg list).
(let (non-nil)
(when (hash-table-p print-number-table)
(maphash (lambda (_k v) (if v (setq non-nil t)))
print-number-table))
(not non-nil)))
;; Output the byte code and constants specially
;; for lazy dynamic loading.
(goto-char position)
(let ((lazy-position (byte-compile-output-as-comment
(cons (car form) (nth 1 form))
t)))
(setq position (point))
(goto-char (point-max))
(princ (format "(#$ . %d) nil" lazy-position)
byte-compile--outbuffer)
(setq form (cdr form))
(setq index (1+ index))))
((eq index cvecindex)
(let* ((cvec (car form))
(len (length cvec))
(index2 0)
elt)
(insert "[")
(while (< index2 len)
(setq elt (aref cvec index2))
(if (byte-code-function-p elt)
(setq position
(byte-compile--output-docform-recurse
'("#[" "]") position
(append elt nil) ; Convert the vector to a list.
2 4 specindex nil))
(prin1 elt byte-compile--outbuffer))
(setq index2 (1+ index2))
(unless (eq index2 len)
(insert " ")))
(insert "]")))
((= index docindex)
(cond
(doc-string-position
(princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
doc-string-position)
byte-compile--outbuffer))
((stringp (car form))
(let ((print-escape-newlines nil))
(goto-char (prog1 (1+ (point))
(prin1 (car form)
byte-compile--outbuffer)))
(insert "\\\n")
(goto-char (point-max))))
(t (prin1 (car form) byte-compile--outbuffer))))
(t (prin1 (car form) byte-compile--outbuffer))))
(insert (cadr info))
position))
(defun byte-compile-output-docform (preface tailpiece name info form
cvecindex docindex
specindex quoted)
"Print a form with a doc string. INFO is (prefix postfix).
If PREFACE, NAME, and TAILPIECE are non-nil, print them too,
before/after INFO and the FORM but after the doc string itself.
CVECINDEX is the index in the FORM of the constant vector, or nil.
DOCINDEX is the index of the doc string (or nil) in the FORM.
If SPECINDEX is non-nil, it is the index in FORM
of the function bytecode string. In that case,
we output that argument and the following argument
@ -2505,73 +2599,30 @@ list that represents a doc string reference.
`defvaralias', `autoload' and `custom-declare-variable' need that."
;; We need to examine byte-compile-dynamic-docstrings
;; in the input buffer (now current), not in the output buffer.
(let ((dynamic-docstrings byte-compile-dynamic-docstrings))
(let ((byte-compile-dynamic-docstrings byte-compile-dynamic-docstrings))
(with-current-buffer byte-compile--outbuffer
(let (position)
;; Insert the doc string, and make it a comment with #@LENGTH.
(when (and (>= (nth 1 info) 0) dynamic-docstrings)
(setq position (byte-compile-output-as-comment
(nth (nth 1 info) form) nil)))
(let ((print-continuous-numbering t)
print-number-table
(index 0)
;; FIXME: The bindings below are only needed for when we're
;; called from ...-defmumble.
(print-escape-newlines t)
(print-length nil)
(print-level nil)
(print-quoted t)
(print-gensym t)
(print-circle t)) ; Handle circular data structures.
(if preface
(progn
;; FIXME: We don't handle uninterned names correctly.
;; E.g. if cl-define-compiler-macro uses uninterned name we get:
;; (defalias '#1=#:foo--cmacro #[514 ...])
;; (put 'foo 'compiler-macro '#:foo--cmacro)
(insert preface)
(prin1 name byte-compile--outbuffer)))
(insert (car info))
(prin1 (car form) byte-compile--outbuffer)
(while (setq form (cdr form))
(setq index (1+ index))
(insert " ")
(cond ((and (numberp specindex) (= index specindex)
;; Don't handle the definition dynamically
;; if it refers (or might refer)
;; to objects already output
;; (for instance, gensyms in the arg list).
(let (non-nil)
(when (hash-table-p print-number-table)
(maphash (lambda (_k v) (if v (setq non-nil t)))
print-number-table))
(not non-nil)))
;; Output the byte code and constants specially
;; for lazy dynamic loading.
(let ((position
(byte-compile-output-as-comment
(cons (car form) (nth 1 form))
t)))
(princ (format "(#$ . %d) nil" position)
byte-compile--outbuffer)
(setq form (cdr form))
(setq index (1+ index))))
((= index (nth 1 info))
(if position
(princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
position)
byte-compile--outbuffer)
(let ((print-escape-newlines nil))
(goto-char (prog1 (1+ (point))
(prin1 (car form)
byte-compile--outbuffer)))
(insert "\\\n")
(goto-char (point-max)))))
(t
(prin1 (car form) byte-compile--outbuffer)))))
(insert (nth 2 info)))))
nil)
(let ((position (point))
(print-continuous-numbering t)
print-number-table
;; FIXME: The bindings below are only needed for when we're
;; called from ...-defmumble.
(print-escape-newlines t)
(print-length nil)
(print-level nil)
(print-quoted t)
(print-gensym t)
(print-circle t)) ; Handle circular data structures.
(when preface
;; FIXME: We don't handle uninterned names correctly.
;; E.g. if cl-define-compiler-macro uses uninterned name we get:
;; (defalias '#1=#:foo--cmacro #[514 ...])
;; (put 'foo 'compiler-macro '#:foo--cmacro)
(insert preface)
(prin1 name byte-compile--outbuffer))
(byte-compile--output-docform-recurse
info position form cvecindex docindex specindex quoted)
(when tailpiece
(insert tailpiece))))))
(defun byte-compile-keep-pending (form &optional handler)
(if (memq byte-optimize '(t source))
@ -2899,60 +2950,58 @@ not to take responsibility for the actual compilation of the code."
;; Otherwise, we have a bona-fide defun/defmacro definition, and use
;; special code to allow dynamic docstrings and byte-code.
(byte-compile-flush-pending)
(let ((index
;; If there's no doc string, provide -1 as the "doc string
;; index" so that no element will be treated as a doc string.
(if (not (stringp (documentation code t))) -1 4)))
(when byte-native-compiling
;; Spill output for the native compiler here.
(push
(if macro
(make-byte-to-native-top-level
:form `(defalias ',name '(macro . ,code) nil)
:lexical lexical-binding)
(make-byte-to-native-func-def :name name
:byte-func code))
byte-to-native-top-level-forms))
;; Output the form by hand, that's much simpler than having
;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform
"\n(defalias '"
bare-name
(if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]"))
(append code nil) ; Turn byte-code-function-p into list.
(and (atom code) byte-compile-dynamic
1)
nil))
(princ ")" byte-compile--outbuffer)
(when byte-native-compiling
;; Spill output for the native compiler here.
(push
(if macro
(make-byte-to-native-top-level
:form `(defalias ',name '(macro . ,code) nil)
:lexical lexical-binding)
(make-byte-to-native-func-def :name name
:byte-func code))
byte-to-native-top-level-forms))
;; Output the form by hand, that's much simpler than having
;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform
"\n(defalias '" ")"
bare-name
(if macro '(" '(macro . #[" "])") '(" #[" "]"))
(append code nil) ; Turn byte-code-function-p into list.
2 4
(and (atom code) byte-compile-dynamic 1)
nil)
t)))))
(defun byte-compile-output-as-comment (exp quoted)
"Print Lisp object EXP in the output file, inside a comment.
Return the file (byte) position it will have.
If QUOTED is non-nil, print with quoting; otherwise, print without quoting."
"Print Lisp object EXP in the output file at point, inside a comment.
Return the file (byte) position it will have. Leave point after
the inserted text. If QUOTED is non-nil, print with quoting;
otherwise, print without quoting."
(with-current-buffer byte-compile--outbuffer
(let ((position (point)))
(let ((position (point)) end)
;; Insert EXP, and make it a comment with #@LENGTH.
(insert " ")
(if quoted
(prin1 exp byte-compile--outbuffer)
(princ exp byte-compile--outbuffer))
(setq end (point-marker))
(set-marker-insertion-type end t)
(goto-char position)
;; Quote certain special characters as needed.
;; get_doc_string in doc.c does the unquoting.
(while (search-forward "\^A" nil t)
(while (search-forward "\^A" end t)
(replace-match "\^A\^A" t t))
(goto-char position)
(while (search-forward "\000" nil t)
(while (search-forward "\000" end t)
(replace-match "\^A0" t t))
(goto-char position)
(while (search-forward "\037" nil t)
(while (search-forward "\037" end t)
(replace-match "\^A_" t t))
(goto-char (point-max))
(goto-char end)
(insert "\037")
(goto-char position)
(insert "#@" (format "%d" (- (position-bytes (point-max))
(insert "#@" (format "%d" (- (position-bytes end)
(position-bytes position))))
;; Save the file position of the object.
@ -2961,7 +3010,8 @@ If QUOTED is non-nil, print with quoting; otherwise, print without quoting."
;; position to a file position.
(prog1
(- (position-bytes (point)) (point-min) -1)
(goto-char (point-max))))))
(goto-char end)
(set-marker end nil)))))
(defun byte-compile--reify-function (fun)
"Return an expression which will evaluate to a function value FUN.

14
lisp/emacs-lisp/cconv.el
View file

@ -615,11 +615,15 @@ places where they originally did not directly appear."
(cconv-convert exp env extend))
(`(,func . ,forms)
;; First element is function or whatever function-like forms are: or, and,
;; if, catch, progn, prog1, while, until
`(,func . ,(mapcar (lambda (form)
(cconv-convert form env extend))
forms)))
(if (symbolp func)
;; First element is function or whatever function-like forms are:
;; or, and, if, catch, progn, prog1, while, until
`(,func . ,(mapcar (lambda (form)
(cconv-convert form env extend))
forms))
(macroexp--warn-wrap form (format-message "Malformed function `%S'"
(car form))
nil nil)))
(_ (or (cdr (assq form env)) form))))

1
lisp/emacs-lisp/cl-generic.el
View file

@ -1379,6 +1379,7 @@ See the full list and their hierarchy in `cl--typeof-types'."
(cl--generic-prefill-dispatchers 0 integer)
(cl--generic-prefill-dispatchers 1 integer)
(cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer)
(cl--generic-prefill-dispatchers 0 (eql 'x) integer)
;;; Dispatch on major mode.

5
lisp/emacs-lisp/eieio-core.el
View file

@ -951,7 +951,10 @@ not nil."
(let ((slots (eieio--class-slots (eieio--object-class obj))))
(dotimes (i (length slots))
(let* ((name (cl--slot-descriptor-name (aref slots i)))
(df (eieio-oref-default obj name)))
;; If the `:initform` signals an error, just skip it,
;; since the error is intended to be signal'ed from
;; `initialize-instance` rather than at the time of `defclass`.
(df (ignore-errors (eieio-oref-default obj name))))
(if (or df set-all)
(eieio-oset obj name df))))))

5
lisp/emacs-lisp/eieio.el
View file

@ -213,9 +213,8 @@ and reference them using the function `class-option'."
,(internal--format-docstring-line
"Retrieve the slot `%S' from an object of class `%S'."
sname name)
;; FIXME: Why is this different from the :reader case?
(if (slot-boundp this ',sname) (eieio-oref this ',sname)))
accessors)
(slot-value this ',sname))
accessors)
(when (and eieio-backward-compatibility (eq alloc :class))
;; FIXME: How could I declare this *method* as obsolete.
(push `(cl-defmethod ,acces ((this (subclass ,name)))

1
lisp/emacs-lisp/loaddefs-gen.el
View file

@ -48,6 +48,7 @@ Standard prefixes won't be registered anyway. I.e. if a file
\"foo.el\" defines variables or functions that use \"foo-\" as
prefix, that will not be registered. But all other prefixes will
be included.")
;;;###autoload
(put 'autoload-compute-prefixes 'safe-local-variable #'booleanp)
(defvar no-update-autoloads nil

2
lisp/emacs-lisp/multisession.el
View file

@ -137,8 +137,6 @@ DOC should be a doc string, and ARGS are keywords as applicable to
(declare-function sqlite-select "sqlite.c")
(declare-function sqlite-open "sqlite.c")
(declare-function sqlite-pragma "sqlite.c")
(declare-function sqlite-transaction "sqlite.c")
(declare-function sqlite-commit "sqlite.c")
(defvar multisession--db nil)

23
lisp/emacs-lisp/shorthands.el
View file

@ -53,11 +53,16 @@
:group 'font-lock-faces)
(defun shorthands--mismatch-from-end (str1 str2)
"Tell index of first mismatch in STR1 and STR2, from end.
The index is a valid 0-based index on STR1. Returns nil if STR1
equals STR2. Return 0 if STR1 is a suffix of STR2."
(cl-loop with l1 = (length str1) with l2 = (length str2)
for i from 1
for i1 = (- l1 i) for i2 = (- l2 i)
while (and (>= i1 0) (>= i2 0) (eq (aref str1 i1) (aref str2 i2)))
finally (return (1- i))))
while (eq (aref str1 i1) (aref str2 i2))
if (zerop i2) return (if (zerop i1) nil i1)
if (zerop i1) return 0
finally (return i1)))
(defun shorthands-font-lock-shorthands (limit)
(when read-symbol-shorthands
@ -69,10 +74,16 @@
font-lock-string-face)))
(intern-soft (match-string 1))))
(sname (and probe (symbol-name probe)))
(mm (and sname (shorthands--mismatch-from-end
(match-string 1) sname))))
(unless (or (null mm) (= mm (length sname)))
(add-face-text-property (match-beginning 1) (1+ (- (match-end 1) mm))
(mismatch (and sname (shorthands--mismatch-from-end
(match-string 1) sname)))
(guess (and mismatch (1+ mismatch))))
(when guess
(when (and (< guess (1- (length (match-string 1))))
;; In bug#67390 we allow other separators
(eq (char-syntax (aref (match-string 1) guess)) ?_))
(setq guess (1+ guess)))
(add-face-text-property (match-beginning 1)
(+ (match-beginning 1) guess)
'elisp-shorthand-font-lock-face))))))
(font-lock-add-keywords 'emacs-lisp-mode '((shorthands-font-lock-shorthands)) t)

7
lisp/epg.el
View file

@ -595,7 +595,12 @@ callback data (if any)."
(if (epg-context-textmode context) '("--textmode"))
(if (epg-context-output-file context)
(list "--output" (epg-context-output-file context)))
(if (epg-context-pinentry-mode context)
(if (and (epg-context-pinentry-mode context)
(not
;; loopback doesn't work with gpgsm
(and (eq (epg-context-protocol context) 'CMS)
(eq (epg-context-pinentry-mode context)
'loopback))))
(list "--pinentry-mode"
(symbol-name (epg-context-pinentry-mode
context))))

96
lisp/erc/erc-fill.el
View file

@ -91,7 +91,8 @@ enables when this option is `erc-fill-wrap' or when the module
an initial \"prefix\" width and `erc-fill-wrap-margin-width'
instead of `erc-fill-column' for influencing initial message
width. For adjusting these during a session, see the commands
`erc-fill-wrap-nudge' and `erc-fill-wrap-refill-buffer'."
`erc-fill-wrap-nudge' and `erc-fill-wrap-refill-buffer'. Read
more about this style in the doc string for `erc-fill-wrap-mode'."
:type '(choice (const :tag "Variable Filling" erc-fill-variable)
(const :tag "Static Filling" erc-fill-static)
(const :tag "Dynamic word-wrap" erc-fill-wrap)
@ -267,6 +268,14 @@ terminals."
:package-version '(ERC . "5.6")
:type 'boolean)
(defface erc-fill-wrap-merge-indicator-face
'((((min-colors 88) (background light)) :foreground "Gray")
(((min-colors 16) (background light)) :foreground "LightGray")
(((min-colors 16) (background dark)) :foreground "DimGray")
(t :inherit shadow))
"ERC `fill-wrap' merge-indicator face."
:group 'erc-faces)
(defcustom erc-fill-wrap-merge-indicator nil
"Indicator to help distinguish between merged messages.
Only matters when the option `erc-fill-wrap-merge' is enabled.
@ -277,21 +286,33 @@ previous message. (Note that the latter variant nullifies any
intervening padding supplied by `erc-fill-line-spacing' and is
meant to supplant that option in text terminals.) In either
case, the second element should be a character, like ?>, and the
last element a valid face. When in doubt, try the first prefab
choice, (pre #xb7 shadow), which replaces a continued speaker's
name with a nondescript dot-product-like glyph in `shadow' face.
This option is currently experimental, and changing its value
mid-session is not supported."
last element a valid face. In special cases, you may also
specify a cons of `pre'/`post' and a string, which tells ERC you
know what you're doing and not to manage the process for you. If
unsure, try either of the first two presets, both of which
replace a continued speaker's name with a dot-product-like glyph
in `shadow' face. Note that this option is still experimental,
and changing its value mid-session is not yet supported (though,
if you must, make sure to run \\[erc-fill-wrap-refill-buffer]
afterward)."
:package-version '(ERC . "5.6")
:type '(choice (const nil)
(const :tag "Leading MIDDLE DOT as speaker (U+00B7)"
(pre #xb7 shadow))
(const :tag "Trailing PARAGRAPH SIGN (U+00B6)"
(post #xb6 shadow))
(const :tag "Leading > as speaker" (pre ?> shadow))
(const :tag "Trailing ~" (post ?~ shadow))
(list :tag "User-provided"
(choice (const pre) (const post)) character face)))
:type
'(choice (const nil)
(const :tag "Leading MIDDLE DOT (U+00B7) as speaker"
(pre #xb7 erc-fill-wrap-merge-indicator-face))
(const :tag "Leading MIDDLE DOT (U+00B7) sans gap"
(pre . #("\u00b7" 0 1 (font-lock-face
erc-fill-wrap-merge-indicator-face))))
(const :tag "Leading RIGHT-ANGLE BRACKET (>) as speaker"
(pre ?> erc-fill-wrap-merge-indicator-face))
(const :tag "Trailing PARAGRAPH SIGN (U+00B6)"
(post #xb6 erc-fill-wrap-merge-indicator-face))
(const :tag "Trailing TILDE (~)"
(post ?~ erc-fill-wrap-merge-indicator-face))
(cons :tag "User-provided string (advanced)"
(choice (const pre) (const post)) string)
(list :tag "User-provided character-face pairing"
(choice (const pre) (const post)) character face)))
(defun erc-fill--wrap-move (normal-cmd visual-cmd &rest args)
(apply (pcase erc-fill--wrap-visual-keys
@ -439,7 +460,9 @@ And it \"wraps\" messages at a common margin width, as determined
by the option `erc-fill-wrap-margin-width'. To use it, either
include `fill-wrap' in `erc-modules' or set `erc-fill-function'
to `erc-fill-wrap'. Most users will want to enable the
`scrolltobottom' module as well. Once active, use
`scrolltobottom' module as well.
During sessions in which this module is active, use
\\[erc-fill-wrap-nudge] to adjust the width of the indent and the
stamp margin, and use \\[erc-fill-wrap-toggle-truncate-lines] for
cycling between logical- and screen-line oriented command
@ -447,7 +470,11 @@ movement. Similarly, use \\[erc-fill-wrap-refill-buffer] to fix
alignment problems after running certain commands, like
`text-scale-adjust'. Also see related stylistic options
`erc-fill-line-spacing', `erc-fill-wrap-merge', and
`erc-fill-wrap-merge-indicator'.
`erc-fill-wrap-merge-indicator'. Hint: in narrow windows, where
is space tight, try setting `erc-fill-static-center' to 1. And
if you also use the option `erc-fill-wrap-merge-indicator', set
that to value-menu item \"Leading MIDDLE DOT (U+00B7) sans gap\"
or one of the various \"trailing\" items.
This module imposes various restrictions on the appearance of
timestamps. Most notably, it insists on displaying them in the
@ -600,29 +627,34 @@ to be disabled."
(save-restriction
(widen)
(cl-assert (= ?\n (char-before (point))))
(unless erc-fill--wrap-merge-indicator-pre
(let ((option erc-fill-wrap-merge-indicator))
(setq erc-fill--wrap-merge-indicator-pre
(propertize (concat (string (nth 1 option)) "\n")
'font-lock-face (nth 2 option)))))
(unless erc-fill--wrap-merge-indicator-post
(let ((option (cdr erc-fill-wrap-merge-indicator)))
(setq erc-fill--wrap-merge-indicator-post
(if (stringp option)
(concat option
(and (not (string-suffix-p "\n" option)) "\n"))
(propertize (concat (string (car option)) "\n")
'font-lock-face (cadr option))))))
(unless (eq (field-at-pos (- (point) 2)) 'erc-timestamp)
(put-text-property (1- (point)) (point)
'display erc-fill--wrap-merge-indicator-pre)))
'display erc-fill--wrap-merge-indicator-post)))
0))
(defun erc-fill--wrap-insert-merged-pre ()
"Add `display' property in lieu of speaker."
(if erc-fill--wrap-merge-indicator-post
(if erc-fill--wrap-merge-indicator-pre
(progn
(put-text-property (point-min) (point) 'display
(car erc-fill--wrap-merge-indicator-post))
(cdr erc-fill--wrap-merge-indicator-post))
(let* ((option erc-fill-wrap-merge-indicator)
(s (concat (propertize (string (nth 1 option))
'font-lock-face (nth 2 option))
" ")))
(car erc-fill--wrap-merge-indicator-pre))
(cdr erc-fill--wrap-merge-indicator-pre))
(let* ((option (cdr erc-fill-wrap-merge-indicator))
(s (if (stringp option)
(concat option)
(concat (propertize (string (car option))
'font-lock-face (cadr option))
" "))))
(put-text-property (point-min) (point) 'display s)
(cdr (setq erc-fill--wrap-merge-indicator-post
(cdr (setq erc-fill--wrap-merge-indicator-pre
(cons s (erc-fill--wrap-measure (point-min) (point))))))))
(defun erc-fill-wrap ()
@ -698,6 +730,8 @@ case this module's insert hooks run by way of the process filter.
With REPAIRP, destructively fill gaps and re-merge speakers."
(goto-char start)
(cl-assert (null erc-fill--wrap-rejigger-last-message))
(setq erc-fill--wrap-merge-indicator-pre nil
erc-fill--wrap-merge-indicator-post nil)
(let (erc-fill--wrap-rejigger-last-message)
(while-let
(((< (point) finish))

4
lisp/erc/erc.el
View file

@ -2394,7 +2394,9 @@ nil."
(set-marker-insertion-type erc-insert-marker t)
(cl-assert (= (field-end erc-insert-marker) erc-input-marker))
(goto-char old-point)
(erc--unhide-prompt))
(let ((erc--hidden-prompt-overlay
(alist-get 'erc--hidden-prompt-overlay continued-session)))
(erc--unhide-prompt)))
(cl-assert (not (get-text-property (point) 'erc-prompt)))
;; In the original version from `erc-open', the snippet that
;; handled these newline insertions appeared twice close in

9
lisp/faces.el
View file

@ -2440,7 +2440,10 @@ If you set `term-file-prefix' to nil, this function does nothing."
'((((supports :slant italic))
:slant italic)
(((supports :underline t))
:underline t)
;; Include italic, even if it isn't supported by the default
;; font, because this face could be merged with another face
;; which uses font that does have an italic variant.
:underline t :slant italic)
(t
;; Default to italic, even if it doesn't appear to be supported,
;; because in some cases the display engine will do its own
@ -2457,7 +2460,9 @@ If you set `term-file-prefix' to nil, this function does nothing."
(defface underline
'((((supports :underline t))
:underline t)
(((supports :weight bold))
;; Include underline, for when this face is merged with another
;; whose font does support underline.
(((supports :weight bold :underline t))
:weight bold)
(t :underline t))
"Basic underlined face."

68
lisp/gnus/gnus-group.el
View file

@ -1745,45 +1745,43 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated."
gnus-level-killed))
(defun gnus-group-search-forward (&optional backward all level first-too)
"Find the next newsgroup with unread articles.
If BACKWARD is non-nil, find the previous newsgroup instead.
If ALL is non-nil, just find any newsgroup.
If LEVEL is non-nil, find group with level LEVEL, or higher if no such
group exists.
If FIRST-TOO, the current line is also eligible as a target."
"Move point to the next newsgroup with unread articles.
If BACKWARD is non-nil, move to the previous newsgroup instead.
If ALL is non-nil, consider any newsgroup, not only those with
unread articles. If LEVEL is non-nil, find group with level
LEVEL, or higher if no such group exists. If FIRST-TOO, the
current line is also eligible as a target."
(let ((way (if backward -1 1))
(low gnus-level-killed)
(beg (point))
pos found lev)
(if (and backward (progn (beginning-of-line)) (bobp))
nil
(unless first-too
(forward-line way))
(while (and
(not (eobp))
(not (setq
found
(and
(get-text-property (point) 'gnus-group)
(or all
(and
(let ((unread
(get-text-property (point) 'gnus-unread)))
(and (numberp unread) (> unread 0)))
(setq lev (get-text-property (point)
'gnus-level))
(<= lev gnus-level-subscribed)))
(or (not level)
(and (setq lev (get-text-property (point)
'gnus-level))
(or (= lev level)
(and (< lev low)
(< level lev)
(progn
(setq low lev)
(setq pos (point))
nil))))))))
(zerop (forward-line way)))))
(unless first-too
(forward-line way))
(while (and
(not (if backward (bobp) (eobp)))
(not (setq
found
(and
(get-text-property (point) 'gnus-group)
(or all
(and
(let ((unread
(get-text-property (point) 'gnus-unread)))
(and (numberp unread) (> unread 0)))
(setq lev (get-text-property (point)
'gnus-level))
(<= lev gnus-level-subscribed)))
(or (not level)
(and (setq lev (get-text-property (point)
'gnus-level))
(or (= lev level)
(and (< lev low)
(< level lev)
(progn
(setq low lev)
(setq pos (point))
nil))))))))
(zerop (forward-line way))))
(if found
(progn (gnus-group-position-point) t)
(goto-char (or pos beg))

24
lisp/indent.el
View file

@ -170,8 +170,7 @@ prefix argument is ignored."
(t
(let ((old-tick (buffer-chars-modified-tick))
(old-point (point))
(old-indent (current-indentation))
(syn (syntax-after (point))))
(old-indent (current-indentation)))
;; Indent the line.
(or (not (eq (indent--funcall-widened indent-line-function) 'noindent))
@ -185,19 +184,14 @@ prefix argument is ignored."
((and (eq tab-always-indent 'complete)
(eql old-point (point))
(eql old-tick (buffer-chars-modified-tick))
(or (null tab-first-completion)
(eq last-command this-command)
(and (eq tab-first-completion 'eol)
(eolp))
(and (memq tab-first-completion
'(word word-or-paren word-or-paren-or-punct))
(not (eql 2 syn)))
(and (memq tab-first-completion
'(word-or-paren word-or-paren-or-punct))
(not (or (eql 4 syn)
(eql 5 syn))))
(and (eq tab-first-completion 'word-or-paren-or-punct)
(not (eql 1 syn)))))
(or (eq last-command this-command)
(let ((syn (syntax-class (syntax-after (point)))))
(pcase tab-first-completion
('nil t)
('eol (eolp))
('word (not (eql 2 syn)))
('word-or-paren (not (memq syn '(2 4 5))))
('word-or-paren-or-punct (not (memq syn '(2 4 5 1))))))))
(completion-at-point))
;; If a prefix argument was given, rigidly indent the following

29
lisp/info.el
View file

@ -1787,11 +1787,24 @@ By default, go to the current Info node."
(interactive (list (Info-read-node-name
"Go to node (default current page): " Info-current-node))
Info-mode)
(browse-url-button-open-url
(Info-url-for-node (format "(%s)%s" (file-name-sans-extension
(file-name-nondirectory
Info-current-file))
node))))
(let (filename)
(string-match "\\s *\\((\\s *\\([^\t)]*\\)\\s *)\\s *\\|\\)\\(.*\\)"
node)
(setq filename (if (= (match-beginning 1) (match-end 1))
""
(match-string 2 node))
node (match-string 3 node))
(let ((trim (string-match "\\s +\\'" filename)))
(if trim (setq filename (substring filename 0 trim))))
(let ((trim (string-match "\\s +\\'" node)))
(if trim (setq node (substring node 0 trim))))
(if (equal filename "")
(setq filename (file-name-sans-extension (file-name-nondirectory
Info-current-file))))
(if (equal node "")
(setq node "Top"))
(browse-url-button-open-url
(Info-url-for-node (format "(%s)%s" filename node)))))
(defun Info-url-for-node (node)
"Return a URL for NODE, a node in the GNU Emacs or Elisp manual.
@ -1817,8 +1830,10 @@ and elisp manuals are supported."
""))
(concat "https://www.gnu.org/software/emacs/manual/html_node/"
manual "/"
(url-hexify-string (string-replace " " "-" node))
".html")))
(and (not (equal node "Top"))
(concat
(url-hexify-string (string-replace " " "-" node))
".html")))))
(defvar Info-read-node-completion-table)

6
lisp/jsonrpc.el
View file

@ -4,7 +4,7 @@
;; Author: João Távora <joaotavora@gmail.com>
;; Keywords: processes, languages, extensions
;; Version: 1.0.17
;; Version: 1.0.18
;; Package-Requires: ((emacs "25.2"))
;; This is a GNU ELPA :core package. Avoid functionality that is not
@ -64,6 +64,7 @@
:initarg :notification-dispatcher
:documentation "Dispatcher for remotely invoked notifications.")
(last-error
:initform nil
:accessor jsonrpc-last-error
:documentation "Last JSONRPC error message received from endpoint.")
(-request-continuations
@ -71,6 +72,7 @@
:accessor jsonrpc--request-continuations
:documentation "A hash table of request ID to continuation lambdas.")
(-events-buffer
:initform nil
:accessor jsonrpc--events-buffer
:documentation "A buffer pretty-printing the JSONRPC events")
(-events-buffer-scrollback-size
@ -286,6 +288,7 @@ CANCEL-ON-INPUT-RETVAL. Any future replies (normal or error) are
ignored."
(let* ((tag (cl-gensym "jsonrpc-request-catch-tag")) id-and-timer
canceled
(throw-on-input nil)
(retval
(unwind-protect
(catch tag
@ -353,6 +356,7 @@ ignored."
:initarg :process :accessor jsonrpc--process
:documentation "Process object wrapped by the this connection.")
(-expected-bytes
:initform nil
:accessor jsonrpc--expected-bytes
:documentation "How many bytes declared by server.")
(-on-shutdown

1
lisp/mail/sendmail.el
View file

@ -269,7 +269,6 @@ The default value matches citations like `foo-bar>' plus whitespace."
(defvar mail-abbrevs-loaded nil)
(defvar mail-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\M-\t" 'completion-at-point)
(define-key map "\C-c?" 'describe-mode)
(define-key map "\C-c\C-f\C-t" 'mail-to)
(define-key map "\C-c\C-f\C-b" 'mail-bcc)

4
lisp/man.el
View file

@ -1191,8 +1191,8 @@ Return the buffer in which the manpage will appear."
(man-args topic)
(bufname
(if (file-remote-p default-directory)
(format "*Man %s %s *" (file-remote-p default-directory) man-args)
(format "*Man %s *" man-args)))
(format "*Man %s %s*" (file-remote-p default-directory) man-args)
(format "*Man %s*" man-args)))
(buffer (get-buffer bufname)))
(if buffer
(Man-notify-when-ready buffer)

23
lisp/net/dbus.el
View file

@ -686,7 +686,9 @@ operation. One of the following keywords is returned:
`:non-existent': Service name does not exist on this bus.
`:not-owner': We are neither the primary owner nor waiting in the
queue of this service."
queue of this service.
When SERVICE is not a known name but a unique name, the function returns nil."
(maphash
(lambda (key value)
@ -698,14 +700,17 @@ queue of this service."
(puthash key (delete elt value) dbus-registered-objects-table)
(remhash key dbus-registered-objects-table)))))))
dbus-registered-objects-table)
(let ((reply (dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"ReleaseName" service)))
(pcase reply
(1 :released)
(2 :non-existent)
(3 :not-owner)
(_ (signal 'dbus-error (list "Could not unregister service" service))))))
(unless (string-prefix-p ":" service)
(let ((reply (dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"ReleaseName" service)))
(pcase reply
(1 :released)
(2 :non-existent)
(3 :not-owner)
(_ (signal
'dbus-error (list "Could not unregister service" service)))))))
(defun dbus-register-signal
(bus service path interface signal handler &rest args)

4
lisp/net/eww.el
View file

@ -657,6 +657,8 @@ The renaming scheme is performed in accordance with
(setq eww-history-position 0)
(and last-coding-system-used
(set-buffer-file-coding-system last-coding-system-used))
(unless shr-fill-text
(visual-line-mode))
(run-hooks 'eww-after-render-hook)
;; Enable undo again so that undo works in text input
;; boxes.
@ -1217,6 +1219,8 @@ the like."
(setq-local shr-url-transformer #'eww--transform-url)
;; Also rescale images when rescaling the text.
(add-hook 'text-scale-mode-hook #'eww--rescale-images nil t)
(setq-local outline-search-function 'shr-outline-search
outline-level 'shr-outline-level)
(setq buffer-read-only t))
(defvar text-scale-mode)

165
lisp/net/shr.el
View file

@ -163,6 +163,48 @@ the specpdl size. If nil, just give up."
:version "28.1"
:type 'boolean)
(defcustom shr-fill-text t
"Non-nil means to fill the text according to the width of the window.
If nil, text is not filled, and `visual-line-mode' can be used to reflow text."
:version "30.1"
:type 'boolean)
(defcustom shr-sup-raise-factor 0.2
"The value of raise property for superscripts.
Should be a non-negative float number between 0 and 1."
:version "30.1"
:type 'float)
(defcustom shr-sub-raise-factor -0.2
"The value of raise property for subscripts.
Should be a non-positive float number between 0 and 1."
:version "30.1"
:type 'float)
(defcustom shr-image-ascent 100
"The value to be used for :ascent property when inserting images."
:version "30.1"
:type 'integer)
(defcustom shr-max-inline-image-size nil
"If non-nil, determines when the images can be displayed inline.
If nil, images are never displayed inline.
It non-nil, it should be cons (WIDTH . HEIGHT).
WIDTH can be an integer which is interpreted as number of pixels. If the width
of an image exceeds this amount, the image is displayed on a separate line.
WIDTH can also be floating point number, in which case the image is displayed
inline if it occupies less than this fraction of window width.
HEIGHT can be also be an integer or a floating point number. If it is an
integer and the pixel height of an image exceeds it, the image image is
displyed on a separate line. If it is a float number , the limit is
interpreted as a multiple of the height of default font."
:version "30.1"
:type '(choice (const nil) (cons number number)))
(defvar shr-content-function nil
"If bound, this should be a function that will return the content.
This is used for cid: URLs, and the function is called with the
@ -697,7 +739,8 @@ size, and full-buffer size."
(replace-match " " t t)))
(defun shr-insert (text)
(when (and (not (bolp))
(when (and (not shr-max-inline-image-size)
(not (bolp))
(get-text-property (1- (point)) 'image-url))
(insert "\n"))
(cond
@ -741,7 +784,7 @@ size, and full-buffer size."
(or shr-current-font 'shr-text)))))))))
(defun shr-fill-lines (start end)
(if (<= shr-internal-width 0)
(if (or (not shr-fill-text) (<= shr-internal-width 0))
nil
(save-restriction
(narrow-to-region start end)
@ -1049,6 +1092,19 @@ the mouse click event."
(declare-function image-size "image.c" (spec &optional pixels frame))
(declare-function image-animate "image" (image &optional index limit position))
(defun shr--inline-image-p (image)
"Return non-nil if IMAGE should be displayed inline."
(when shr-max-inline-image-size
(let ((size (image-size image t))
(max-width (car shr-max-inline-image-size))
(max-height (cdr shr-max-inline-image-size)))
(unless (integerp max-width)
(setq max-width (* max-width (window-width nil t))))
(unless (integerp max-height)
(setq max-height (* max-height (frame-char-height))))
(and (< (car size) max-width)
(< (cdr size) max-height)))))
(defun shr-put-image (spec alt &optional flags)
"Insert image SPEC with a string ALT. Return image.
SPEC is either an image data blob, or a list where the first
@ -1063,11 +1119,11 @@ element is the data blob and the second element is the content-type."
(start (point))
(image (cond
((eq size 'original)
(create-image data nil t :ascent 100
(create-image data nil t :ascent shr-image-ascent
:format content-type))
((eq content-type 'image/svg+xml)
(when (image-type-available-p 'svg)
(create-image data 'svg t :ascent 100)))
(create-image data 'svg t :ascent shr-image-ascent)))
((eq size 'full)
(ignore-errors
(shr-rescale-image data content-type
@ -1079,19 +1135,25 @@ element is the data blob and the second element is the content-type."
(plist-get flags :width)
(plist-get flags :height)))))))
(when image
;; The trailing space can confuse shr-insert into not
;; putting any space after inline images.
(setq alt (string-trim alt))
;; When inserting big-ish pictures, put them at the
;; beginning of the line.
(when (and (> (current-column) 0)
(> (car (image-size image t)) 400))
(insert "\n"))
(let ((image-pos (point)))
(if (eq size 'original)
(insert-sliced-image image (or alt "*") nil 20 1)
(insert-image image (or alt "*")))
(put-text-property start (point) 'image-size size)
(when (and shr-image-animate
(cdr (image-multi-frame-p image)))
(image-animate image nil 60 image-pos))))
(let ((inline (shr--inline-image-p image)))
(when (and (> (current-column) 0)
(not inline))
(insert "\n"))
(let ((image-pos (point)))
(if (eq size 'original)
(insert-sliced-image image (or alt "*") nil 20 1)
(insert-image image (or alt "*")))
(put-text-property start (point) 'image-size size)
(when (and (not inline) shr-max-inline-image-size)
(insert "\n"))
(when (and shr-image-animate
(cdr (image-multi-frame-p image)))
(image-animate image nil 60 image-pos)))))
image)
(insert (or alt ""))))
@ -1114,7 +1176,7 @@ The size of the displayed image will not exceed
MAX-WIDTH/MAX-HEIGHT. If not given, use the current window
width/height instead."
(if (not (get-buffer-window (current-buffer) t))
(create-image data nil t :ascent 100)
(create-image data nil t :ascent shr-image-ascent)
(let* ((edges (window-inside-pixel-edges
(get-buffer-window (current-buffer))))
(max-width (truncate (* shr-max-image-proportion
@ -1135,13 +1197,13 @@ width/height instead."
(< (* height scaling) max-height))
(create-image
data (shr--image-type) t
:ascent 100
:ascent shr-image-ascent
:width width
:height height
:format content-type)
(create-image
data (shr--image-type) t
:ascent 100
:ascent shr-image-ascent
:max-width max-width
:max-height max-height
:format content-type)))))
@ -1210,7 +1272,11 @@ START, and END. Note that START and END should be markers."
(defun shr-heading (dom &rest types)
(shr-ensure-paragraph)
(apply #'shr-fontize-dom dom types)
(let ((start (point))
(level (string-to-number
(string-remove-prefix "shr-h" (symbol-name (car types))))))
(apply #'shr-fontize-dom dom types)
(put-text-property start (pos-eol) 'outline-level level))
(shr-ensure-paragraph))
(defun shr-urlify (start url &optional title)
@ -1381,13 +1447,20 @@ ones, in case fg and bg are nil."
(defun shr-tag-sup (dom)
(let ((start (point)))
(shr-generic dom)
(put-text-property start (point) 'display '(raise 0.2))
(put-text-property start (point) 'display `(raise ,shr-sup-raise-factor))
(add-face-text-property start (point) 'shr-sup)))
(defun shr-tag-sub (dom)
;; Why would a subscript be at the beginning of a line? It does
;; happen sometimes because of a <br> tag and the intent seems to be
;; alignment of subscript and superscript but I don't think that is
;; possible in Emacs. So we remove the newline in that case.
(when (bolp)
(forward-char -1)
(delete-char 1))
(let ((start (point)))
(shr-generic dom)
(put-text-property start (point) 'display '(raise -0.2))
(put-text-property start (point) 'display `(raise ,shr-sub-raise-factor))
(add-face-text-property start (point) 'shr-sup)))
(defun shr-tag-p (dom)
@ -1652,7 +1725,8 @@ The preference is a float determined from `shr-prefer-media-type'."
(and dom
(or (> (length (dom-attr dom 'src)) 0)
(> (length (dom-attr dom 'srcset)) 0))))
(when (> (current-column) 0)
(when (and (not shr-max-inline-image-size)
(> (current-column) 0))
(insert "\n"))
(let ((alt (dom-attr dom 'alt))
(width (shr-string-number (dom-attr dom 'width)))
@ -1703,8 +1777,14 @@ The preference is a float determined from `shr-prefer-media-type'."
(when (image-type-available-p 'svg)
(insert-image
(shr-make-placeholder-image dom)
(or alt "")))
(insert " ")
(or (string-trim alt) "")))
;; Paradoxically this space causes shr not to insert spaces after
;; inline images. Since the image is temporary it seem like there
;; should be no downside to not inserting it but since I don't
;; understand the code well and for the sake of backward compatibility
;; we preserve it unless user has set `shr-max-inline-image-size'.
(unless shr-max-inline-image-size
(insert " "))
(url-queue-retrieve
url #'shr-image-fetched
(list (current-buffer) start (set-marker (make-marker) (point))
@ -1840,7 +1920,7 @@ BASE is the URL of the HTML being rendered."
(svg-rectangle svg 0 0 width height :gradient "background"
:stroke-width 2 :stroke-color "black")
(let ((image (svg-image svg :scale 1)))
(setf (image-property image :ascent) 100)
(setf (image-property image :ascent) shr-image-ascent)
image)))
(defun shr-tag-pre (dom)
@ -2000,6 +2080,41 @@ BASE is the URL of the HTML being rendered."
(shr-generic dom)
(insert ?\N{POP DIRECTIONAL ISOLATE}))
;;; Outline Support
(defun shr-outline-search (&optional bound move backward looking-at)
"A function that can be used as `outline-search-function' for rendered html.
See `outline-search-function' for BOUND, MOVE, BACKWARD and LOOKING-AT."
(if looking-at
(get-text-property (point) 'outline-level)
(let ((heading-found nil)
(bound (or bound
(if backward (point-min) (point-max)))))
(save-excursion
(when (and (not (bolp))
(get-text-property (point) 'outline-level))
(forward-line (if backward -1 1)))
(if backward
(unless (get-text-property (point) 'outline-level)
(goto-char (or (previous-single-property-change
(point) 'outline-level nil bound)
bound)))
(goto-char (or (text-property-not-all (point) bound 'outline-level nil)
bound)))
(goto-char (pos-bol))
(when (get-text-property (point) 'outline-level)
(setq heading-found (point))))
(if heading-found
(progn
(set-match-data (list heading-found heading-found))
(goto-char heading-found))
(when move
(goto-char bound)
nil)))))
(defun shr-outline-level ()
"Function to be used as `outline-level' with `shr-outline-search'."
(get-text-property (point) 'outline-level))
;;; Table rendering algorithm.
;; Table rendering is the only complicated thing here. We do this by

27
lisp/net/tramp.el
View file

@ -552,14 +552,17 @@ host runs a restricted shell, it shall be added to this list, too."
;;;###tramp-autoload
(defcustom tramp-local-host-regexp
(rx
bos
(| (literal tramp-system-name)
(| "localhost" "localhost4" "localhost6" "127.0.0.1" "::1"))
eos)
(rx bos
(| (literal tramp-system-name)
(| "localhost" "127.0.0.1" "::1"
;; Fedora.
"localhost4" "localhost6"
;; Ubuntu.
"ip6-localhost" "ip6-loopback"))
eos)
"Host names which are regarded as local host.
If the local host runs a chrooted environment, set this to nil."
:version "29.1"
:version "30.1"
:type '(choice (const :tag "Chrooted environment" nil)
(regexp :tag "Host regexp")))
@ -747,8 +750,9 @@ The regexp should match at end of buffer."
;; A security key requires the user physically to touch the device
;; with their finger. We must tell it to the user.
;; Added in OpenSSH 8.2. I've tested it with yubikey. Nitrokey,
;; which has also passed the tests, does not show such a message.
;; Added in OpenSSH 8.2. I've tested it with yubikey. Nitrokey and
;; Titankey, which have also passed the tests, do not show such a
;; message.
(defcustom tramp-security-key-confirm-regexp
(rx bol (* "\r") "Confirm user presence for key " (* nonl) (* (any "\r\n")))
"Regular expression matching security key confirmation message.
@ -6727,7 +6731,14 @@ If PROCESS is a process object which contains the property
`remote-pid', or PROCESS is a number and REMOTE is a remote file name,
PROCESS is interpreted as process on the respective remote host, which
will be the process to signal.
If PROCESS is a string, it is interpreted as process object with
the respective process name, or as a number.
SIGCODE may be an integer, or a symbol whose name is a signal name."
(when (stringp process)
(setq process (or (get-process process)
(and (string-match-p (rx bol (+ digit) eol) process)
(string-to-number process))
(signal 'wrong-type-argument (list #'processp process)))))
(let (pid vec)
(cond
((processp process)

1
lisp/nxml/nxml-mode.el
View file

@ -390,7 +390,6 @@ reference.")
"C-c C-u" #'nxml-insert-named-char
"C-c C-o" nxml-outline-prefix-map
"/" #'nxml-electric-slash
"M-TAB" #'completion-at-point
"S-<mouse-2>" #'nxml-mouse-hide-direct-text-content)
(defvar nxml-font-lock-keywords

17
lisp/progmodes/c-ts-mode.el
View file

@ -356,11 +356,27 @@ PARENT, BOL, ARGS are the same as other anchor functions."
(apply (alist-get 'standalone-parent treesit-simple-indent-presets)
parent (treesit-node-parent parent) bol args))
(defun c-ts-mode--prev-line-match (regexp)
"An indentation matcher that matches if previous line matches REGEXP."
(lambda (_n _p bol &rest _)
(save-excursion
(goto-char bol)
(forward-line -1)
(back-to-indentation)
(looking-at-p regexp))))
(defun c-ts-mode--indent-styles (mode)
"Indent rules supported by `c-ts-mode'.
MODE is either `c' or `cpp'."
(let ((common
`((c-ts-mode--for-each-tail-body-matcher prev-line c-ts-mode-indent-offset)
;; If the user types "if (...)" and hits RET, they expect
;; point on the empty line to be indented; this rule
;; does that.
((and no-node
(c-ts-mode--prev-line-match
,(rx (or "if" "else" "while" "do" "for"))))
prev-line c-ts-mode-indent-offset)
((parent-is "translation_unit") column-0 0)
((query "(ERROR (ERROR)) @indent") column-0 0)
@ -453,6 +469,7 @@ MODE is either `c' or `cpp'."
;; These rules are for cases where the body is bracketless.
;; Tested by the "Bracketless Simple Statement" test.
((parent-is "if_statement") standalone-parent c-ts-mode-indent-offset)
((parent-is "else_clause") standalone-parent c-ts-mode-indent-offset)
((parent-is "for_statement") standalone-parent c-ts-mode-indent-offset)
((parent-is "while_statement") standalone-parent c-ts-mode-indent-offset)
((parent-is "do_statement") standalone-parent c-ts-mode-indent-offset)

5
lisp/progmodes/eglot.el
View file

@ -977,15 +977,19 @@ ACTION is an LSP object of either `CodeAction' or `Command' type."
:accessor eglot--project-nickname
:reader eglot-project-nickname)
(languages
:initform nil
:documentation "Alist ((MODE . LANGUAGE-ID-STRING)...) of managed languages."
:accessor eglot--languages)
(capabilities
:initform nil
:documentation "JSON object containing server capabilities."
:accessor eglot--capabilities)
(server-info
:initform nil
:documentation "JSON object containing server info."
:accessor eglot--server-info)
(shutdown-requested
:initform nil
:documentation "Flag set when server is shutting down."
:accessor eglot--shutdown-requested)
(project
@ -1002,6 +1006,7 @@ ACTION is an LSP object of either `CodeAction' or `Command' type."
:documentation "Map (DIR -> (WATCH ID1 ID2...)) for `didChangeWatchedFiles'."
:initform (make-hash-table :test #'equal) :accessor eglot--file-watches)
(managed-buffers
:initform nil
:documentation "List of buffers managed by server."
:accessor eglot--managed-buffers)
(saved-initargs

329
lisp/progmodes/elixir-ts-mode.el
View file

@ -86,17 +86,35 @@
:group 'elixir-ts
:version "30.1")
(defface elixir-ts-font-comment-doc-identifier-face
(defface elixir-ts-comment-doc-identifier
'((t (:inherit font-lock-doc-face)))
"Face used for @comment.doc tags in Elixir files.")
"Face used for doc identifiers in Elixir files."
:group 'elixir-ts)
(defface elixir-ts-font-comment-doc-attribute-face
(defface elixir-ts-comment-doc-attribute
'((t (:inherit font-lock-doc-face)))
"Face used for @comment.doc.__attribute__ tags in Elixir files.")
"Face used for doc attributes in Elixir files."
:group 'elixir-ts)
(defface elixir-ts-font-sigil-name-face
(defface elixir-ts-sigil-name
'((t (:inherit font-lock-string-face)))
"Face used for @__name__ tags in Elixir files.")
"Face used for sigils in Elixir files."
:group 'elixir-ts)
(defface elixir-ts-atom
'((t (:inherit font-lock-constant-face)))
"Face used for atoms in Elixir files."
:group 'elixir-ts)
(defface elixir-ts-keyword-key
'((t (:inherit elixir-ts-atom)))
"Face used for keyword keys in Elixir files."
:group 'elixir-ts)
(defface elixir-ts-attribute
'((t (:inherit font-lock-preprocessor-face)))
"Face used for attributes in Elixir files."
:group 'elixir-ts)
(defconst elixir-ts--sexp-regexp
(rx bol
@ -114,7 +132,10 @@
"defoverridable" "defp" "defprotocol" "defstruct"))
(defconst elixir-ts--definition-keywords-re
(concat "^" (regexp-opt elixir-ts--definition-keywords) "$"))
(concat "^" (regexp-opt
(append elixir-ts--definition-keywords
elixir-ts--test-definition-keywords))
"$"))
(defconst elixir-ts--kernel-keywords
'("alias" "case" "cond" "else" "for" "if" "import" "quote"
@ -334,56 +355,73 @@
(treesit-node-start
(treesit-node-parent
(treesit-node-at (point) 'elixir))))
0)))))
0)))))
(defvar elixir-ts--font-lock-settings
(treesit-font-lock-rules
:language 'elixir
:feature 'elixir-function-name
`((call target: (identifier) @target-identifier
(arguments (identifier) @font-lock-function-name-face)
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(call target: (identifier) @target-identifier
(arguments
(call target: (identifier) @font-lock-function-name-face))
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(call target: (identifier) @target-identifier
(arguments
(binary_operator
left: (call target: (identifier) @font-lock-function-name-face)))
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(call target: (identifier) @target-identifier
(arguments (identifier) @font-lock-function-name-face)
(do_block)
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(call target: (identifier) @target-identifier
(arguments
(call target: (identifier) @font-lock-function-name-face))
(do_block)
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(call target: (identifier) @target-identifier
(arguments
(binary_operator
left: (call target: (identifier) @font-lock-function-name-face)))
(do_block)
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(unary_operator
operator: "@"
(call (arguments
(binary_operator
left: (call target: (identifier) @font-lock-function-name-face))))))
;; A function definition like "def _foo" is valid, but we should
;; not apply the comment-face unless its a non-function identifier, so
;; the comment matches has to be after the function matches.
:language 'elixir
:feature 'elixir-comment
'((comment) @font-lock-comment-face)
'((comment) @font-lock-comment-face
((identifier) @font-lock-comment-face
(:match "^_[a-z]\\|^_$" @font-lock-comment-face)))
:language 'elixir
:feature 'elixir-string
:override t
'([(string) (charlist)] @font-lock-string-face)
:language 'elixir
:feature 'elixir-string-interpolation
:override t
'((string
[
quoted_end: _ @font-lock-string-face
quoted_start: _ @font-lock-string-face
(quoted_content) @font-lock-string-face
(interpolation
"#{" @font-lock-regexp-grouping-backslash "}"
@font-lock-regexp-grouping-backslash)
])
(charlist
[
quoted_end: _ @font-lock-string-face
quoted_start: _ @font-lock-string-face
(quoted_content) @font-lock-string-face
(interpolation
"#{" @font-lock-regexp-grouping-backslash "}"
@font-lock-regexp-grouping-backslash)
]))
:language 'elixir
:feature 'elixir-keyword
`(,elixir-ts--reserved-keywords-vector
@font-lock-keyword-face
(binary_operator
operator: _ @font-lock-keyword-face
(:match ,elixir-ts--reserved-keywords-re @font-lock-keyword-face)))
:feature 'elixir-variable
`((call target: (identifier)
(arguments
(binary_operator
(call target: (identifier)
(arguments ((identifier) @font-lock-variable-use-face))))))
(call target: (identifier)
(arguments
(call target: (identifier)
(arguments ((identifier)) @font-lock-variable-use-face))))
(dot left: (identifier) @font-lock-variable-use-face operator: "." ))
:language 'elixir
:feature 'elixir-doc
:override t
`((unary_operator
operator: "@" @elixir-ts-font-comment-doc-attribute-face
operator: "@" @elixir-ts-comment-doc-attribute
operand: (call
target: (identifier) @elixir-ts-font-comment-doc-identifier-face
target: (identifier) @elixir-ts-comment-doc-identifier
;; Arguments can be optional, so adding another
;; entry without arguments.
;; If we don't handle then we don't apply font
@ -395,93 +433,35 @@
(charlist) @font-lock-doc-face
(sigil) @font-lock-doc-face
(boolean) @font-lock-doc-face
(keywords) @font-lock-doc-face
]))
(:match ,elixir-ts--doc-keywords-re
@elixir-ts-font-comment-doc-identifier-face))
@elixir-ts-comment-doc-identifier))
(unary_operator
operator: "@" @elixir-ts-font-comment-doc-attribute-face
operator: "@" @elixir-ts-comment-doc-attribute
operand: (call
target: (identifier) @elixir-ts-font-comment-doc-identifier-face)
target: (identifier) @elixir-ts-comment-doc-identifier)
(:match ,elixir-ts--doc-keywords-re
@elixir-ts-font-comment-doc-identifier-face)))
@elixir-ts-comment-doc-identifier)))
:language 'elixir
:feature 'elixir-unary-operator
`((unary_operator operator: "@" @font-lock-preprocessor-face
operand: [
(identifier) @font-lock-preprocessor-face
(call target: (identifier)
@font-lock-preprocessor-face)
(boolean) @font-lock-preprocessor-face
(nil) @font-lock-preprocessor-face
])
(unary_operator operator: "&") @font-lock-function-name-face
(operator_identifier) @font-lock-operator-face)
:language 'elixir
:feature 'elixir-operator
'((binary_operator operator: _ @font-lock-operator-face)
(dot operator: _ @font-lock-operator-face)
(stab_clause operator: _ @font-lock-operator-face)
[(boolean) (nil)] @font-lock-constant-face
[(integer) (float)] @font-lock-number-face
(alias) @font-lock-type-face
(call target: (dot left: (atom) @font-lock-type-face))
(char) @font-lock-constant-face
[(atom) (quoted_atom)] @font-lock-type-face
[(keyword) (quoted_keyword)] @font-lock-builtin-face)
:language 'elixir
:feature 'elixir-call
`((call
target: (identifier) @font-lock-keyword-face
(:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face))
(call
target: (identifier) @font-lock-keyword-face
(:match ,elixir-ts--kernel-keywords-re @font-lock-keyword-face))
(call
target: [(identifier) @font-lock-function-name-face
(dot right: (identifier) @font-lock-keyword-face)])
(call
target: (identifier) @font-lock-keyword-face
(arguments
[
(identifier) @font-lock-keyword-face
(binary_operator
left: (identifier) @font-lock-keyword-face
operator: "when")
])
(:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face))
(call
target: (identifier) @font-lock-keyword-face
(arguments
(binary_operator
operator: "|>"
right: (identifier)))
(:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face)))
:language 'elixir
:feature 'elixir-constant
`((binary_operator operator: "|>" right: (identifier)
@font-lock-function-name-face)
((identifier) @font-lock-keyword-face
(:match ,elixir-ts--builtin-keywords-re
@font-lock-keyword-face))
((identifier) @font-lock-comment-face
(:match "^_" @font-lock-comment-face))
(identifier) @font-lock-function-name-face
["%"] @font-lock-keyward-face
["," ";"] @font-lock-keyword-face
["(" ")" "[" "]" "{" "}" "<<" ">>"] @font-lock-keyword-face)
:feature 'elixir-string
'((interpolation
"#{" @font-lock-escape-face
"}" @font-lock-escape-face)
(string (quoted_content) @font-lock-string-face)
(quoted_keyword (quoted_content) @font-lock-string-face)
(charlist (quoted_content) @font-lock-string-face)
["\"" "'" "\"\"\""] @font-lock-string-face)
:language 'elixir
:feature 'elixir-sigil
:override t
`((sigil
(sigil_name) @elixir-ts-font-sigil-name-face
(:match "^[^HF]$" @elixir-ts-font-sigil-name-face))
(sigil_name) @elixir-ts-sigil-name
(quoted_content) @font-lock-string-face
;; HEEx and Surface templates will handled by
;; heex-ts-mode if its available.
(:match "^[^HF]$" @elixir-ts-sigil-name))
@font-lock-string-face
(sigil
(sigil_name) @font-lock-regexp-face
@ -489,15 +469,92 @@
@font-lock-regexp-face
(sigil
"~" @font-lock-string-face
(sigil_name) @elixir-ts-font-sigil-name-face
(sigil_name) @font-lock-string-face
quoted_start: _ @font-lock-string-face
quoted_end: _ @font-lock-string-face
(:match "^[HF]$" @elixir-ts-font-sigil-name-face)))
quoted_end: _ @font-lock-string-face))
:language 'elixir
:feature 'elixir-operator
`(["!"] @font-lock-negation-char-face
["%"] @font-lock-bracket-face
["," ";"] @font-lock-operator-face
["(" ")" "[" "]" "{" "}" "<<" ">>"] @font-lock-bracket-face)
:language 'elixir
:feature 'elixir-data-type
'([(atom) (alias)] @font-lock-type-face
(keywords (pair key: (keyword) @elixir-ts-keyword-key))
[(keyword) (quoted_keyword)] @elixir-ts-atom
[(boolean) (nil)] @elixir-ts-atom
(unary_operator operator: "@" @elixir-ts-attribute
operand: [
(identifier) @elixir-ts-attribute
(call target: (identifier)
@elixir-ts-attribute)
(boolean) @elixir-ts-attribute
(nil) @elixir-ts-attribute
])
(operator_identifier) @font-lock-operator-face)
:language 'elixir
:feature 'elixir-keyword
`(,elixir-ts--reserved-keywords-vector
@font-lock-keyword-face
(binary_operator
operator: _ @font-lock-keyword-face
(:match ,elixir-ts--reserved-keywords-re @font-lock-keyword-face))
(binary_operator operator: _ @font-lock-operator-face)
(call
target: (identifier) @font-lock-keyword-face
(:match ,elixir-ts--definition-keywords-re @font-lock-keyword-face))
(call
target: (identifier) @font-lock-keyword-face
(:match ,elixir-ts--kernel-keywords-re @font-lock-keyword-face)))
:language 'elixir
:feature 'elixir-function-call
'((call target: (identifier) @font-lock-function-call-face)
(unary_operator operator: "&" @font-lock-operator-face
operand: (binary_operator
left: (identifier)
@font-lock-function-call-face
operator: "/" right: (integer)))
(call
target: (dot right: (identifier) @font-lock-function-call-face))
(unary_operator operator: "&" @font-lock-variable-name-face
operand: (integer) @font-lock-variable-name-face)
(unary_operator operator: "&" @font-lock-operator-face
operand: (list)))
:language 'elixir
:feature 'elixir-string-escape
:override t
`((escape_sequence) @font-lock-regexp-grouping-backslash))
`((escape_sequence) @font-lock-escape-face)
:language 'elixir
:feature 'elixir-number
'([(integer) (float)] @font-lock-number-face)
:language 'elixir
:feature 'elixir-variable
'((binary_operator left: (identifier) @font-lock-variable-name-face)
(binary_operator right: (identifier) @font-lock-variable-name-face)
(arguments ( (identifier) @font-lock-variable-name-face))
(tuple (identifier) @font-lock-variable-name-face)
(list (identifier) @font-lock-variable-name-face)
(pair value: (identifier) @font-lock-variable-name-face)
(body (identifier) @font-lock-variable-name-face)
(unary_operator operand: (identifier) @font-lock-variable-name-face)
(interpolation (identifier) @font-lock-variable-name-face)
(do_block (identifier) @font-lock-variable-name-face))
:language 'elixir
:feature 'elixir-builtin
:override t
`(((identifier) @font-lock-builtin-face
(:match ,elixir-ts--builtin-keywords-re
@font-lock-builtin-face))))
"Tree-sitter font-lock settings.")
(defvar elixir-ts--treesit-range-rules
@ -640,10 +697,12 @@ Return nil if NODE is not a defun node or doesn't have a name."
;; Font-lock.
(setq-local treesit-font-lock-settings elixir-ts--font-lock-settings)
(setq-local treesit-font-lock-feature-list
'(( elixir-comment elixir-constant elixir-doc )
( elixir-string elixir-keyword elixir-unary-operator
elixir-call elixir-operator )
( elixir-sigil elixir-string-escape elixir-string-interpolation)))
'(( elixir-comment elixir-doc elixir-function-name)
( elixir-string elixir-keyword elixir-data-type)
( elixir-sigil elixir-variable elixir-builtin
elixir-string-escape)
( elixir-function-call elixir-operator elixir-number )))
;; Imenu.
(setq-local treesit-simple-imenu-settings
@ -675,13 +734,13 @@ Return nil if NODE is not a defun node or doesn't have a name."
heex-ts--indent-rules))
(setq-local treesit-font-lock-feature-list
'(( elixir-comment elixir-constant elixir-doc
'(( elixir-comment elixir-doc elixir-function-name
heex-comment heex-keyword heex-doctype )
( elixir-string elixir-keyword elixir-unary-operator
elixir-call elixir-operator
heex-component heex-tag heex-attribute heex-string)
( elixir-sigil elixir-string-escape
elixir-string-interpolation ))))
( elixir-string elixir-keyword elixir-data-type
heex-component heex-tag heex-attribute heex-string )
( elixir-sigil elixir-variable elixir-builtin
elixir-string-escape)
( elixir-function-call elixir-operator elixir-number ))))
(treesit-major-mode-setup)
(setq-local syntax-propertize-function #'elixir-ts--syntax-propertize)))

3
lisp/progmodes/erts-mode.el
View file

@ -181,7 +181,8 @@ expected results and the actual results in a separate buffer."
(ert-test--erts-test
(list (cons 'dummy t)
(cons 'code (car (read-from-string test-function)))
(cons 'point-char (erts-mode--preceding-spec "Point-Char")))
(cons 'point-char (save-match-data
(erts-mode--preceding-spec "Point-Char"))))
(buffer-file-name))
(:success (message "Test successful"))
(ert-test-failed

150
lisp/progmodes/lua-ts-mode.el
View file

@ -44,6 +44,7 @@
(declare-function treesit-node-first-child-for-pos "treesit.c")
(declare-function treesit-node-parent "treesit.c")
(declare-function treesit-node-start "treesit.c")
(declare-function treesit-node-end "treesit.c")
(declare-function treesit-node-type "treesit.c")
(declare-function treesit-parser-create "treesit.c")
(declare-function treesit-search-subtree "treesit.c")
@ -133,135 +134,141 @@
"Lua built-in functions for tree-sitter font-locking.")
(defvar lua-ts--keywords
'("and" "do" "else" "elseif" "end" "for" "function"
"goto" "if" "in" "local" "not" "or" "repeat"
"return" "then" "until" "while")
'("and" "do" "else" "elseif" "end" "for" "function" "goto" "if"
"in" "local" "not" "or" "repeat" "return" "then" "until" "while")
"Lua keywords for tree-sitter font-locking and navigation.")
(defun lua-ts--comment-font-lock (node override start end &rest _)
"Apply font lock to comment NODE within START and END.
Applies `font-lock-comment-delimiter-face' and
`font-lock-comment-face'. See `treesit-fontify-with-override' for
values of OVERRIDE."
(let* ((node-start (treesit-node-start node))
(node-end (treesit-node-end node))
(node-text (treesit-node-text node t))
(delimiter-end (+ 2 node-start)))
(when (and (>= node-start start)
(<= delimiter-end end)
(string-match "\\`--" node-text))
(treesit-fontify-with-override node-start
delimiter-end
font-lock-comment-delimiter-face
override))
(treesit-fontify-with-override (max delimiter-end start)
(min node-end end)
font-lock-comment-face
override)))
(defvar lua-ts--font-lock-settings
(treesit-font-lock-rules
:language 'lua
:default-language 'lua
:feature 'bracket
'(["(" ")" "[" "]" "{" "}"] @font-lock-bracket-face)
:language 'lua
:feature 'delimiter
'(["," ";"] @font-lock-delimiter-face)
:language 'lua
:feature 'constant
'((variable_list
attribute: (attribute (["<" ">"] (identifier))))
@font-lock-constant-face
(goto_statement (identifier) @font-lock-constant-face)
(label_statement) @font-lock-constant-face)
'([(variable_list
attribute: (attribute (["<" ">"] (identifier))))
(label_statement)
(true) (false) (nil)]
@font-lock-constant-face)
:language 'lua
:feature 'operator
'(["and" "not" "or" "+" "-" "*" "/" "%" "^"
"#" "==" "~=" "<=" ">=" "<" ">" "=" "&"
"~" "|" "<<" ">>" "//" ".."]
@font-lock-operator-face
(vararg_expression) @font-lock-operator-face)
'(["+" "-" "*" "/" "%" "^" "#" "==" "~=" "<=" ">="
"<" ">" "=" "&" "~" "|" "<<" ">>" "//" ".."
(vararg_expression)]
@font-lock-operator-face)
:language 'lua
:feature 'builtin
`(((identifier) @font-lock-builtin-face
(:match ,(regexp-opt lua-ts--builtins 'symbols)
@font-lock-builtin-face)))
:language 'lua
:feature 'function
'((function_call name: (identifier) @font-lock-function-call-face)
(function_call
name: (method_index_expression
method: (identifier) @font-lock-function-call-face))
(method_index_expression
method: (identifier) @font-lock-function-call-face))
(function_call
name: (dot_index_expression (identifier) @font-lock-function-call-face)))
(dot_index_expression
field: (identifier) @font-lock-function-call-face)))
:language 'lua
:feature 'punctuation
'(["." ":"] @font-lock-punctuation-face)
:language 'lua
:feature 'variable
'((function_call
arguments: (arguments (identifier))
@font-lock-variable-use-face)
(arguments (identifier) @font-lock-variable-use-face))
(function_call
name: (method_index_expression
table: (identifier) @font-lock-variable-use-face)))
(arguments
(binary_expression (identifier) @font-lock-variable-use-face)))
(function_call
(arguments
(bracket_index_expression (identifier) @font-lock-variable-use-face)))
(function_declaration
(parameters name: (identifier) @font-lock-variable-name-face)))
:language 'lua
:feature 'number
'((number) @font-lock-number-face)
:language 'lua
:feature 'keyword
`((break_statement) @font-lock-keyword-face
(true) @font-lock-constant-face
(false) @font-lock-constant-face
(nil) @font-lock-constant-face
,(vconcat lua-ts--keywords)
@font-lock-keyword-face)
`([(break_statement)
,(vconcat lua-ts--keywords)]
@font-lock-keyword-face
(goto_statement ((identifier) @font-lock-constant-face)))
:language 'lua
:feature 'string
'((string) @font-lock-string-face)
:language 'lua
:feature 'escape
:override t
'((escape_sequence) @font-lock-escape-face)
:language 'lua
:feature 'comment
'((comment) @font-lock-comment-face
'((comment) @lua-ts--comment-font-lock
(hash_bang_line) @font-lock-comment-face)
:language 'lua
:feature 'definition
'((function_declaration
name: (identifier) @font-lock-function-name-face)
(assignment_statement
(variable_list name: [(identifier)]) @font-lock-function-name-face
(expression_list value: (function_definition)))
(table_constructor
(field
name: (identifier) @font-lock-function-name-face
value: (function_definition)))
(identifier) @font-lock-function-name-face)
(function_declaration
name: (dot_index_expression (identifier) @font-lock-function-name-face))
(function_declaration
name: (method_index_expression (identifier) @font-lock-function-name-face))
(dot_index_expression
field: (identifier) @font-lock-function-name-face))
(function_declaration
(method_index_expression
method: (identifier) @font-lock-function-name-face))
(assignment_statement
(variable_list
(identifier) @font-lock-function-name-face)
(expression_list value: (function_definition)))
(field
name: (identifier) @font-lock-function-name-face
value: (function_definition))
(assignment_statement
(variable_list
(dot_index_expression
table: (identifier) @font-lock-function-name-face
field: (identifier) @font-lock-property-name-face
)))
(parameters
name: (identifier) @font-lock-variable-name-face)
field: (identifier) @font-lock-function-name-face))
(expression_list
value:
(function_definition))))
:feature 'assignment
'((variable_list (identifier) @font-lock-variable-name-face)
(variable_list
(bracket_index_expression
field: (identifier) @font-lock-variable-name-face))
(variable_list
(dot_index_expression
field: (identifier) @font-lock-variable-name-face))
(for_numeric_clause name: (identifier) @font-lock-variable-name-face))
:language 'lua
:feature 'property
'((field name: (identifier) @font-lock-property-name-face)
(dot_index_expression
field: (identifier) @font-lock-property-use-face))
:language 'lua
:feature 'assignment
'((variable_list
[(identifier)
(bracket_index_expression)]
@font-lock-variable-name-face)
(variable_list
(dot_index_expression
table: (identifier))
@font-lock-variable-name-face))
:language 'lua
:feature 'error
:override t
'((ERROR) @font-lock-warning-face))
@ -665,13 +672,14 @@ Calls REPORT-FN directly."
(setq-local treesit-font-lock-settings lua-ts--font-lock-settings)
(setq-local treesit-font-lock-feature-list
'((comment definition)
(keyword property string)
(keyword string)
(assignment builtin constant number)
(bracket
delimiter
escape
function
operator
property
punctuation
variable)))

14
lisp/progmodes/project.el
View file

@ -1800,15 +1800,15 @@ It's also possible to enter an arbitrary directory not in the list."
(choices
(let (ret)
;; Iterate in reverse order so project--name-history is in
;; the correct order.
;; the same order as project--list.
(dolist (dir (reverse (project-known-project-roots)))
;; we filter out directories that no longer map to a project,
;; We filter out directories that no longer map to a project,
;; since they don't have a clean project-name.
(when-let (proj (project--find-in-directory dir))
(let ((name (project-name proj)))
(push name project--name-history)
(push (cons name proj) ret))))
ret))
(when-let ((proj (project--find-in-directory dir))
(name (project-name proj)))
(push name project--name-history)
(push (cons name proj) ret)))
(reverse ret)))
;; XXX: Just using this for the category (for the substring
;; completion style).
(table (project--file-completion-table

12
lisp/progmodes/ruby-ts-mode.el
View file

@ -197,8 +197,8 @@
(defun ruby-ts--comment-font-lock (node override start end &rest _)
"Apply font lock to comment NODE within START and END.
Applies `font-lock-comment-delimiter-face' and
`font-lock-comment-face' See `treesit-fontify-with-override' for
values of OVERRIDE"
`font-lock-comment-face'. See `treesit-fontify-with-override' for
values of OVERRIDE."
;; Empirically it appears as if (treesit-node-start node) will be
;; where the # character is at and (treesit-node-end node) will be
;; the end of the line
@ -1128,6 +1128,7 @@ leading double colon is not added."
bol
(or
"class"
"singleton_class"
"module"
"method"
"array"
@ -1137,15 +1138,22 @@ leading double colon is not added."
"array_pattern"
"hash_pattern"
"if"
"else"
"then"
"unless"
"case"
"case_match"
"when"
"while"
"until"
"for"
"block"
"do_block"
"begin"
"integer"
"identifier"
"self"
"super"
"constant"
"simple_symbol"
"hash_key_symbol"

13
lisp/progmodes/rust-ts-mode.el
View file

@ -153,7 +153,7 @@
:language 'rust
:feature 'comment
'(([(block_comment) (line_comment)]) @font-lock-comment-face)
'(([(block_comment) (line_comment)]) @rust-ts-mode--comment-docstring)
:language 'rust
:feature 'delimiter
@ -293,6 +293,17 @@
'((ERROR) @font-lock-warning-face))
"Tree-sitter font-lock settings for `rust-ts-mode'.")
(defun rust-ts-mode--comment-docstring (node override start end &rest _args)
"Use the comment or documentation face appropriately for comments."
(let* ((beg (treesit-node-start node))
(end (treesit-node-end node))
(face (save-excursion
(goto-char beg)
(if (looking-at "///")
'font-lock-doc-face
'font-lock-comment-face))))
(treesit-fontify-with-override beg end face override start end)))
(defun rust-ts-mode--fontify-scope (node override start end &optional tail-p)
(let* ((case-fold-search nil)
(face

5
lisp/progmodes/typescript-ts-mode.el
View file

@ -107,6 +107,9 @@ Argument LANGUAGE is either `typescript' or `tsx'."
((parent-is "member_expression") parent-bol typescript-ts-mode-indent-offset)
((parent-is "named_imports") parent-bol typescript-ts-mode-indent-offset)
((parent-is "statement_block") parent-bol typescript-ts-mode-indent-offset)
((or (node-is "case")
(node-is "default"))
parent-bol typescript-ts-mode-indent-offset)
((parent-is "switch_case") parent-bol typescript-ts-mode-indent-offset)
((parent-is "switch_default") parent-bol typescript-ts-mode-indent-offset)
((parent-is "type_arguments") parent-bol typescript-ts-mode-indent-offset)
@ -483,7 +486,7 @@ This mode is intended to be inherited by concrete major modes."
'((comment declaration)
(keyword string escape-sequence)
(constant expression identifier number pattern property)
(function bracket delimiter)))
(operator function bracket delimiter)))
(setq-local syntax-propertize-function #'typescript-ts--syntax-propertize)
(treesit-major-mode-setup)))

298
lisp/register.el
View file

@ -35,6 +35,8 @@
;; FIXME: Clean up namespace usage!
(declare-function frameset-register-p "frameset")
(cl-defstruct
(registerv (:constructor nil)
(:constructor registerv--make (&optional data print-func
@ -98,6 +100,15 @@ If nil, do not show register previews, unless `help-char' (or a member of
:version "24.4"
:type '(choice number (const :tag "No preview unless requested" nil))
:group 'register)
(make-obsolete-variable 'register-preview-delay "No longer used." "30.1")
(defcustom register-preview-default-keys (mapcar #'string (number-sequence ?a ?z))
"Default keys for setting a new register."
:type '(repeat string))
(defcustom register-use-preview t
"Always show register preview when non nil."
:type 'boolean)
(defun get-register (register)
"Return contents of Emacs register named REGISTER, or nil if none."
@ -120,7 +131,8 @@ See the documentation of the variable `register-alist' for possible VALUEs."
(defun register-preview-default (r)
"Function that is the default value of the variable `register-preview-function'."
(format "%s: %s\n"
(single-key-description (car r))
(propertize (string (car r))
'display (single-key-description (car r)))
(register-describe-oneline (car r))))
(defvar register-preview-function #'register-preview-default
@ -128,53 +140,263 @@ See the documentation of the variable `register-alist' for possible VALUEs."
Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
The function should return a string, the description of the argument.")
(defun register-preview (buffer &optional show-empty)
(cl-defstruct register-preview-info
"Store data for a specific register command.
TYPES are the types of register supported.
MSG is the minibuffer message to send when a register is selected.
ACT is the type of action the command is doing on register.
SMATCH accept a boolean value to say if command accept non matching register."
types msg act smatch)
(cl-defgeneric register-command-info (command)
"Returns a `register-preview-info' object storing data for COMMAND."
(ignore command))
(cl-defmethod register-command-info ((_command (eql insert-register)))
(make-register-preview-info
:types '(string number)
:msg "Insert register `%s'"
:act 'insert
:smatch t))
(cl-defmethod register-command-info ((_command (eql jump-to-register)))
(make-register-preview-info
:types '(window frame marker kmacro
file buffer file-query)
:msg "Jump to register `%s'"
:act 'jump
:smatch t))
(cl-defmethod register-command-info ((_command (eql view-register)))
(make-register-preview-info
:types '(all)
:msg "View register `%s'"
:act 'view
:smatch t))
(cl-defmethod register-command-info ((_command (eql append-to-register)))
(make-register-preview-info
:types '(string number)
:msg "Append to register `%s'"
:act 'modify
:smatch t))
(cl-defmethod register-command-info ((_command (eql prepend-to-register)))
(make-register-preview-info
:types '(string number)
:msg "Prepend to register `%s'"
:act 'modify
:smatch t))
(cl-defmethod register-command-info ((_command (eql increment-register)))
(make-register-preview-info
:types '(string number)
:msg "Increment register `%s'"
:act 'modify
:smatch t))
(defun register-preview-forward-line (arg)
"Move to next or previous line in register preview buffer.
If ARG is positive goto next line, if negative to previous.
Do nothing when defining or executing kmacros."
;; Ensure user enter manually key in minibuffer when recording a macro.
(unless (or defining-kbd-macro executing-kbd-macro
(not (get-buffer-window "*Register Preview*" 'visible)))
(let ((fn (if (> arg 0) #'eobp #'bobp))
(posfn (if (> arg 0)
#'point-min
(lambda () (1- (point-max)))))
str)
(with-current-buffer "*Register Preview*"
(let ((ovs (overlays-in (point-min) (point-max)))
pos)
(goto-char (if ovs
(overlay-start (car ovs))
(point-min)))
(setq pos (point))
(and ovs (forward-line arg))
(when (and (funcall fn)
(or (> arg 0) (eql pos (point))))
(goto-char (funcall posfn)))
(setq str (buffer-substring-no-properties
(pos-bol) (1+ (pos-bol))))
(remove-overlays)
(with-selected-window (minibuffer-window)
(delete-minibuffer-contents)
(insert str)))))))
(defun register-preview-next ()
"Goto next line in register preview buffer."
(interactive)
(register-preview-forward-line 1))
(defun register-preview-previous ()
"Goto previous line in register preview buffer."
(interactive)
(register-preview-forward-line -1))
(defun register-type (register)
"Return REGISTER type.
Current register types actually returned are one of:
- string
- number
- marker
- buffer
- file
- file-query
- window
- frame
- kmacro
One can add new types to a specific command by defining a new `cl-defmethod'
matching this command. Predicate for type in new `cl-defmethod' should
satisfy `cl-typep' otherwise the new type should be defined with
`cl-deftype'."
;; Call register--type against the register value.
(register--type (if (consp (cdr register))
(cadr register)
(cdr register))))
(cl-defgeneric register--type (regval)
"Returns type of register value REGVAL."
(ignore regval))
(cl-defmethod register--type ((_regval string)) 'string)
(cl-defmethod register--type ((_regval number)) 'number)
(cl-defmethod register--type ((_regval marker)) 'marker)
(cl-defmethod register--type ((_regval (eql 'buffer))) 'buffer)
(cl-defmethod register--type ((_regval (eql 'file))) 'file)
(cl-defmethod register--type ((_regval (eql 'file-query))) 'file-query)
(cl-defmethod register--type ((_regval window-configuration)) 'window)
(cl-deftype frame-register () '(satisfies frameset-register-p))
(cl-defmethod register--type :extra "frame-register" (_regval) 'frame)
(cl-deftype kmacro-register () '(satisfies kmacro-register-p))
(cl-defmethod register--type :extra "kmacro-register" (_regval) 'kmacro)
(defun register-of-type-alist (types)
"Filter `register-alist' according to TYPES."
(if (memq 'all types)
register-alist
(cl-loop for register in register-alist
when (memq (register-type register) types)
collect register)))
(defun register-preview (buffer &optional show-empty types)
"Pop up a window showing the registers preview in BUFFER.
If SHOW-EMPTY is non-nil, show the window even if no registers.
Argument TYPES (a list) specify the types of register to show, when nil show all
registers, see `register-type' for suitable types.
Format of each entry is controlled by the variable `register-preview-function'."
(when (or show-empty (consp register-alist))
(with-current-buffer-window
buffer
(cons 'display-buffer-below-selected
'((window-height . fit-window-to-buffer)
(preserve-size . (nil . t))))
nil
(with-current-buffer standard-output
(setq cursor-in-non-selected-windows nil)
(mapc (lambda (elem)
(when (get-register (car elem))
(insert (funcall register-preview-function elem))))
register-alist)))))
(let ((registers (register-of-type-alist (or types '(all)))))
(when (or show-empty (consp registers))
(with-current-buffer-window
buffer
(cons 'display-buffer-below-selected
'((window-height . fit-window-to-buffer)
(preserve-size . (nil . t))))
nil
(with-current-buffer standard-output
(setq cursor-in-non-selected-windows nil)
(mapc (lambda (elem)
(when (get-register (car elem))
(insert (funcall register-preview-function elem))))
registers))))))
(cl-defgeneric register-preview-get-defaults (action)
"Returns default registers according to ACTION."
(ignore action))
(cl-defmethod register-preview-get-defaults ((_action (eql set)))
(cl-loop for s in register-preview-default-keys
unless (assoc (string-to-char s) register-alist)
collect s))
(defun register-read-with-preview (prompt)
"Read and return a register name, possibly showing existing registers.
Prompt with the string PROMPT. If `register-alist' and
`register-preview-delay' are both non-nil, display a window
listing existing registers after `register-preview-delay' seconds.
Prompt with the string PROMPT.
If `help-char' (or a member of `help-event-list') is pressed,
display such a window regardless."
(let* ((buffer "*Register Preview*")
(timer (when (numberp register-preview-delay)
(run-with-timer register-preview-delay nil
(lambda ()
(unless (get-buffer-window buffer)
(register-preview buffer))))))
(help-chars (cl-loop for c in (cons help-char help-event-list)
when (not (get-register c))
collect c)))
(pat "")
(map (let ((m (make-sparse-keymap)))
(set-keymap-parent m minibuffer-local-map)
m))
(data (register-command-info this-command))
types msg result timer act win strs smatch)
(if data
(setq types (register-preview-info-types data)
msg (register-preview-info-msg data)
act (register-preview-info-act data)
smatch (register-preview-info-smatch data))
(setq types '(all)
msg "Overwrite register `%s'"
act 'set))
(setq strs (mapcar (lambda (x)
(string (car x)))
(register-of-type-alist types)))
(when (and (memq act '(insert jump view)) (null strs))
(error "No register suitable for `%s'" act))
(dolist (k (cons help-char help-event-list))
(define-key map
(vector k) (lambda ()
(interactive)
(unless (get-buffer-window buffer)
(with-selected-window (minibuffer-selected-window)
(register-preview buffer 'show-empty types))))))
(define-key map (kbd "<down>") 'register-preview-next)
(define-key map (kbd "<up>") 'register-preview-previous)
(define-key map (kbd "C-n") 'register-preview-next)
(define-key map (kbd "C-p") 'register-preview-previous)
(unless (or executing-kbd-macro (null register-use-preview))
(register-preview buffer nil types))
(unwind-protect
(progn
(while (memq (read-key (propertize prompt 'face 'minibuffer-prompt))
help-chars)
(unless (get-buffer-window buffer)
(register-preview buffer 'show-empty)))
(when (or (eq ?\C-g last-input-event)
(eq 'escape last-input-event)
(eq ?\C-\[ last-input-event))
(keyboard-quit))
(if (characterp last-input-event) last-input-event
(error "Non-character input-event")))
(and (timerp timer) (cancel-timer timer))
(progn
(minibuffer-with-setup-hook
(lambda ()
(setq timer
(run-with-idle-timer
0.01 'repeat
(lambda ()
(with-selected-window (minibuffer-window)
(let ((input (minibuffer-contents)))
(when (> (length input) 1)
(let ((new (substring input 1))
(old (substring input 0 1)))
(setq input (if (or (null smatch)
(member new strs))
new old))
(delete-minibuffer-contents)
(insert input)))
(when (and smatch (not (string= input ""))
(not (member input strs)))
(setq input "")
(delete-minibuffer-contents)
(minibuffer-message "Not matching"))
(when (not (string= input pat))
(setq pat input))))
(if (setq win (get-buffer-window buffer))
(with-selected-window win
(let ((ov (make-overlay (point-min) (point-min))))
(goto-char (point-min))
(remove-overlays)
(unless (string= pat "")
(if (re-search-forward (concat "^" pat) nil t)
(progn (move-overlay
ov
(match-beginning 0) (pos-eol))
(overlay-put ov 'face 'match)
(when msg
(with-selected-window (minibuffer-window)
(minibuffer-message msg pat))))
(with-selected-window (minibuffer-window)
(minibuffer-message
"Register `%s' is empty" pat))))))
(unless (string= pat "")
(if (member pat strs)
(with-selected-window (minibuffer-window)
(minibuffer-message msg pat))
(with-selected-window (minibuffer-window)
(minibuffer-message
"Register `%s' is empty" pat)))))))))
(setq result (read-from-minibuffer
prompt nil map nil nil (register-preview-get-defaults act))))
(cl-assert (and result (not (string= result "")))
nil "No register specified")
(string-to-char result))
(when timer (cancel-timer timer))
(let ((w (get-buffer-window buffer)))
(and (window-live-p w) (delete-window w)))
(and (get-buffer buffer) (kill-buffer buffer)))))

12
lisp/simple.el
View file

@ -4274,19 +4274,19 @@ This buffer is used when `shell-command' or `shell-command-on-region'
is run interactively. A value of nil means that output to stderr and
stdout will be intermixed in the output stream.")
(declare-function mailcap-file-default-commands "mailcap" (files))
(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep))
(declare-function shell-command-guess "dired-aux" (files))
(defun minibuffer-default-add-shell-commands ()
"Return a list of all commands associated with the current file.
This function is used to add all related commands retrieved by `mailcap'
to the end of the list of defaults just after the default value."
(interactive)
This function is used to add all related commands retrieved by
`shell-command-guess' to the end of the list of defaults just
after the default value."
(let* ((filename (if (listp minibuffer-default)
(car minibuffer-default)
minibuffer-default))
(commands (and filename (require 'mailcap nil t)
(mailcap-file-default-commands (list filename)))))
(commands (and filename (require 'dired-aux)
(shell-command-guess (list filename)))))
(setq commands (mapcar (lambda (command)
(concat command " " filename))
commands))

4
lisp/sqlite.el
View file

@ -23,6 +23,10 @@
;;; Code:
(declare-function sqlite-transaction "sqlite.c")
(declare-function sqlite-commit "sqlite.c")
(declare-function sqlite-rollback "sqlite.c")
(defmacro with-sqlite-transaction (db &rest body)
"Execute BODY while holding a transaction for DB.
If BODY completes normally, commit the changes and return

23
lisp/textmodes/ispell.el
View file

@ -3680,6 +3680,28 @@ If APPEND is non-nil, don't erase previous debugging output."
(if (>= column (- (window-width) 2))
(scroll-left (max (- column (window-width) -3) 10)))))))
;;;###autoload
(defun ispell-completion-at-point ()
"Word completion function for use in `completion-at-point-functions'."
(pcase (bounds-of-thing-at-point 'word)
(`(,beg . ,end)
(when (and (< beg (point)) (<= (point) end))
(let* ((word (buffer-substring-no-properties beg end))
(len (length word))
(inhibit-message t)
(all (cons word (ispell-lookup-words word)))
(cur all))
(while cur
(unless (string-prefix-p word (car cur))
(setcar cur (concat word (substring (car cur) len))))
(while (when-let ((next (cadr cur)))
(not (string-prefix-p word next t)))
(setcdr cur (cddr cur)))
(setq cur (cdr cur)))
(list beg end (cdr all)
:annotation-function (lambda (_) " Dictionary word")
:exclusive 'no))))))
;;; Interactive word completion.
;; Forces "previous-word" processing. Do we want to make this selectable?
@ -3696,7 +3718,6 @@ This command uses a word-list file specified
by `ispell-alternate-dictionary' or by `ispell-complete-word-dict';
if none of those name an existing word-list file, this command
signals an error."
;; FIXME: completion-at-point-function.
(interactive "P")
(let ((case-fold-search-val case-fold-search)
(word (ispell-get-word nil "\\*")) ; force "previous-word" processing.

19
lisp/textmodes/text-mode.el
View file

@ -73,8 +73,20 @@
(defvar-keymap text-mode-map
:doc "Keymap for `text-mode'.
Many other modes, such as `mail-mode' and `outline-mode', inherit
all the commands defined in this map."
"C-M-i" #'ispell-complete-word)
all the commands defined in this map.")
(defcustom text-mode-meta-tab-ispell-complete-word nil
"Whether M-TAB invokes `ispell-complete-word' in Text mode.
This user option only takes effect when you customize it in
Custom or with `setopt', not with `setq'."
:group 'text
:type 'boolean
:version "30.1"
:set (lambda (sym val)
(if (set sym val)
(keymap-set text-mode-map "C-M-i" #'ispell-complete-word)
(keymap-unset text-mode-map "C-M-i" t))))
(easy-menu-define text-mode-menu text-mode-map
"Menu for `text-mode'."
@ -131,7 +143,8 @@ Turning on Text mode runs the normal hook `text-mode-hook'."
;; Enable text conversion in this buffer.
(setq-local text-conversion-style t)
(add-hook 'context-menu-functions 'text-mode-context-menu 10 t))
(add-hook 'context-menu-functions 'text-mode-context-menu 10 t)
(add-hook 'completion-at-point-functions #'ispell-completion-at-point 10 t))
(define-derived-mode paragraph-indent-text-mode text-mode "Parindent"
"Major mode for editing text, with leading spaces starting a paragraph.

12
lisp/vc/vc.el
View file

@ -1071,19 +1071,23 @@ Within directories, only files already under version control are noticed."
(defvar diff-vc-backend)
(defvar diff-vc-revisions)
;; Maybe we could even use comint-mode rather than shell-mode?
(defvar vc-deduce-backend-nonvc-modes
(defcustom vc-deduce-backend-nonvc-modes
;; Maybe we could even use comint-mode rather than shell-mode?
'(dired-mode shell-mode eshell-mode compilation-mode)
"List of modes not supported by VC where backend should be deduced.
In these modes the backend is deduced based on `default-directory'.
When nil, the backend is deduced in all modes.")
If the value is t, the backend is deduced in all modes."
:type '(choice (const :tag "None" nil)
(repeat symbol)
(const :tag "All" t))
:version "30.1")
(defun vc-deduce-backend ()
(cond ((derived-mode-p 'vc-dir-mode) vc-dir-backend)
((derived-mode-p 'log-view-mode) log-view-vc-backend)
((derived-mode-p 'log-edit-mode) log-edit-vc-backend)
((derived-mode-p 'diff-mode) diff-vc-backend)
((or (null vc-deduce-backend-nonvc-modes)
((or (eq vc-deduce-backend-nonvc-modes t)
(derived-mode-p vc-deduce-backend-nonvc-modes))
(ignore-errors (vc-responsible-backend default-directory)))
(vc-mode (vc-backend buffer-file-name))))

7
lisp/wdired.el
View file

@ -261,6 +261,10 @@ See `wdired-mode'."
(add-function :override (local 'revert-buffer-function) #'wdired-revert)
(set-buffer-modified-p nil)
(setq buffer-undo-list nil)
;; Non-nil `dired-filename-display-length' may cause filenames to be
;; hidden partly, so we remove filename invisibility spec
;; temporarily to ensure filenames are visible for editing.
(dired-filename-update-invisibility-spec)
(run-mode-hooks 'wdired-mode-hook)
(message "%s" (substitute-command-keys
"Press \\[wdired-finish-edit] when finished \
@ -456,6 +460,9 @@ non-nil means return old filename."
(dired-sort-set-mode-line)
(dired-advertise)
(dired-hide-details-update-invisibility-spec)
;; Restore filename invisibility spec that is removed in
;; `wdired-change-to-wdired-mode'.
(dired-filename-update-invisibility-spec)
(remove-hook 'kill-buffer-hook #'wdired-check-kill-buffer t)
(remove-hook 'before-change-functions #'wdired--before-change-fn t)
(remove-hook 'after-change-functions #'wdired--restore-properties t)

14
lisp/window.el
View file

@ -5682,7 +5682,8 @@ Return the new window.
If optional argument SIZE is omitted or nil, both windows get the
same height, or close to it. If SIZE is positive, the upper
\(selected) window gets SIZE lines. If SIZE is negative, the
lower (new) window gets -SIZE lines.
lower (new) window gets -SIZE lines. Interactively, SIZE is
the prefix numeric argument.
If the variable `split-window-keep-point' is non-nil, both
windows get the same value of point as the WINDOW-TO-SPLIT.
@ -5734,8 +5735,9 @@ amount of redisplay; this is convenient on slow terminals."
"Split root window of current frame in two.
The current window configuration is retained in the top window,
the lower window takes up the whole width of the frame. SIZE is
handled as in `split-window-below'."
(interactive "P")
handled as in `split-window-below', and interactively is the
prefix numeric argument."
(interactive "p")
(split-window-below size (frame-root-window)))
(defun split-window-right (&optional size window-to-split)
@ -5752,7 +5754,7 @@ same width, or close to it. If SIZE is positive, the left-hand
right-hand (new) window gets -SIZE columns. Here, SIZE includes
the width of the window's scroll bar; if there are no scroll
bars, it includes the width of the divider column to the window's
right, if any."
right, if any. Interactively, SIZE is the prefix numeric argument."
(interactive `(,(when current-prefix-arg
(prefix-numeric-value current-prefix-arg))
,(selected-window)))
@ -5774,8 +5776,8 @@ right, if any."
The current window configuration is retained within the left
window, and a new window is created on the right, taking up the
whole height of the frame. SIZE is treated as by
`split-window-right'."
(interactive "P")
`split-window-right' and interactively, is the prefix numeric argument."
(interactive "p")
(split-window-right size (frame-root-window)))
;;; Balancing windows.

75
src/pdumper.c
View file

@ -3002,7 +3002,8 @@ dump_vectorlike (struct dump_context *ctx,
# error "pvec_type changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Vector *v = XVECTOR (lv);
switch (PSEUDOVECTOR_TYPE (v))
enum pvec_type ptype = PSEUDOVECTOR_TYPE (v);
switch (ptype)
{
case PVEC_FONT:
/* There are three kinds of font objects that all use PVEC_FONT,
@ -3020,76 +3021,60 @@ dump_vectorlike (struct dump_context *ctx,
case PVEC_SUB_CHAR_TABLE:
case PVEC_RECORD:
case PVEC_PACKAGE:
offset = dump_vectorlike_generic (ctx, &v->header);
break;
return dump_vectorlike_generic (ctx, &v->header);
case PVEC_BOOL_VECTOR:
offset = dump_bool_vector(ctx, v);
break;
return dump_bool_vector(ctx, v);
case PVEC_HASH_TABLE:
offset = dump_hash_table (ctx, lv, offset);
break;
return dump_hash_table (ctx, lv, offset);
case PVEC_BUFFER:
offset = dump_buffer (ctx, XBUFFER (lv));
break;
return dump_buffer (ctx, XBUFFER (lv));
case PVEC_SUBR:
offset = dump_subr (ctx, XSUBR (lv));
break;
return dump_subr (ctx, XSUBR (lv));
case PVEC_FRAME:
case PVEC_WINDOW:
case PVEC_PROCESS:
case PVEC_TERMINAL:
offset = dump_nilled_pseudovec (ctx, &v->header);
break;
return dump_nilled_pseudovec (ctx, &v->header);
case PVEC_MARKER:
offset = dump_marker (ctx, XMARKER (lv));
break;
return dump_marker (ctx, XMARKER (lv));
case PVEC_OVERLAY:
offset = dump_overlay (ctx, XOVERLAY (lv));
break;
return dump_overlay (ctx, XOVERLAY (lv));
case PVEC_FINALIZER:
offset = dump_finalizer (ctx, XFINALIZER (lv));
break;
return dump_finalizer (ctx, XFINALIZER (lv));
case PVEC_BIGNUM:
offset = dump_bignum (ctx, lv);
break;
#ifdef HAVE_NATIVE_COMP
return dump_bignum (ctx, lv);
case PVEC_NATIVE_COMP_UNIT:
offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv));
break;
#ifdef HAVE_NATIVE_COMP
return dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv));
#endif
case PVEC_WINDOW_CONFIGURATION:
error_unsupported_dump_object (ctx, lv, "window configuration");
case PVEC_OTHER:
error_unsupported_dump_object (ctx, lv, "other?!");
case PVEC_XWIDGET:
error_unsupported_dump_object (ctx, lv, "xwidget");
case PVEC_XWIDGET_VIEW:
error_unsupported_dump_object (ctx, lv, "xwidget view");
case PVEC_MISC_PTR:
case PVEC_USER_PTR:
error_unsupported_dump_object (ctx, lv, "smuggled pointers");
break;
case PVEC_THREAD:
if (main_thread_p (v))
{
eassert (dump_object_emacs_ptr (lv));
return DUMP_OBJECT_IS_RUNTIME_MAGIC;
}
error_unsupported_dump_object (ctx, lv, "thread");
break;
case PVEC_WINDOW_CONFIGURATION:
case PVEC_OTHER:
case PVEC_XWIDGET:
case PVEC_XWIDGET_VIEW:
case PVEC_MISC_PTR:
case PVEC_USER_PTR:
case PVEC_MUTEX:
error_unsupported_dump_object (ctx, lv, "mutex");
case PVEC_CONDVAR:
error_unsupported_dump_object (ctx, lv, "condvar");
case PVEC_SQLITE:
error_unsupported_dump_object (ctx, lv, "sqlite");
case PVEC_MODULE_FUNCTION:
error_unsupported_dump_object (ctx, lv, "module function");
case PVEC_SYMBOL_WITH_POS:
error_unsupported_dump_object (ctx, lv, "symbol with pos");
default:
error_unsupported_dump_object(ctx, lv, "weird pseudovector");
case PVEC_FREE:
case PVEC_TS_PARSER:
case PVEC_TS_NODE:
case PVEC_TS_COMPILED_QUERY:
break;
}
return offset;
char msg[60];
snprintf (msg, sizeof msg, "pseudovector type %d", (int) ptype);
error_unsupported_dump_object (ctx, lv, msg);
}
/* Add an object to the dump.

281
src/print.c
View file

@ -1599,76 +1599,69 @@ print_pointer (Lisp_Object printcharfun, char *buf, const char *prefix,
}
#endif
static bool
print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
char *buf)
static void
print_bignum (Lisp_Object obj, Lisp_Object printcharfun)
{
/* First do all the vectorlike types that have a readable syntax. */
switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
ptrdiff_t size = bignum_bufsize (obj, 10);
USE_SAFE_ALLOCA;
char *str = SAFE_ALLOCA (size);
ptrdiff_t len = bignum_to_c_string (str, size, obj, 10);
strout (str, len, len, printcharfun);
SAFE_FREE ();
}
static void
print_bool_vector (Lisp_Object obj, Lisp_Object printcharfun)
{
EMACS_INT size = bool_vector_size (obj);
ptrdiff_t size_in_bytes = bool_vector_bytes (size);
ptrdiff_t real_size_in_bytes = size_in_bytes;
unsigned char *data = bool_vector_uchar_data (obj);
char buf[sizeof "#&" + INT_STRLEN_BOUND (ptrdiff_t)];
int len = sprintf (buf, "#&%"pI"d\"", size);
strout (buf, len, len, printcharfun);
/* Don't print more bytes than the specified maximum.
Negative values of print-length are invalid. Treat them
like a print-length of nil. */
if (FIXNATP (Vprint_length)
&& XFIXNAT (Vprint_length) < size_in_bytes)
size_in_bytes = XFIXNAT (Vprint_length);
for (ptrdiff_t i = 0; i < size_in_bytes; i++)
{
case PVEC_BIGNUM:
{
ptrdiff_t size = bignum_bufsize (obj, 10);
USE_SAFE_ALLOCA;
char *str = SAFE_ALLOCA (size);
ptrdiff_t len = bignum_to_c_string (str, size, obj, 10);
strout (str, len, len, printcharfun);
SAFE_FREE ();
}
return true;
case PVEC_BOOL_VECTOR:
{
EMACS_INT size = bool_vector_size (obj);
ptrdiff_t size_in_bytes = bool_vector_bytes (size);
ptrdiff_t real_size_in_bytes = size_in_bytes;
unsigned char *data = bool_vector_uchar_data (obj);
int len = sprintf (buf, "#&%"pI"d\"", size);
strout (buf, len, len, printcharfun);
/* Don't print more bytes than the specified maximum.
Negative values of print-length are invalid. Treat them
like a print-length of nil. */
if (FIXNATP (Vprint_length)
&& XFIXNAT (Vprint_length) < size_in_bytes)
size_in_bytes = XFIXNAT (Vprint_length);
for (ptrdiff_t i = 0; i < size_in_bytes; i++)
{
maybe_quit ();
unsigned char c = data[i];
if (c == '\n' && print_escape_newlines)
print_c_string ("\\n", printcharfun);
else if (c == '\f' && print_escape_newlines)
print_c_string ("\\f", printcharfun);
else if (c > '\177'
|| (print_escape_control_characters && c_iscntrl (c)))
{
/* Use octal escapes to avoid encoding issues. */
octalout (c, data, i + 1, size_in_bytes, printcharfun);
}
else
{
if (c == '\"' || c == '\\')
printchar ('\\', printcharfun);
printchar (c, printcharfun);
}
}
if (size_in_bytes < real_size_in_bytes)
print_c_string (" ...", printcharfun);
printchar ('\"', printcharfun);
}
return true;
default:
break;
maybe_quit ();
unsigned char c = data[i];
if (c == '\n' && print_escape_newlines)
print_c_string ("\\n", printcharfun);
else if (c == '\f' && print_escape_newlines)
print_c_string ("\\f", printcharfun);
else if (c > '\177'
|| (print_escape_control_characters && c_iscntrl (c)))
{
/* Use octal escapes to avoid encoding issues. */
octalout (c, data, i + 1, size_in_bytes, printcharfun);
}
else
{
if (c == '\"' || c == '\\')
printchar ('\\', printcharfun);
printchar (c, printcharfun);
}
}
/* Then do all the pseudovector types that don't have a readable
syntax. First check whether this is handled by
`print-unreadable-function'. */
if (size_in_bytes < real_size_in_bytes)
print_c_string (" ...", printcharfun);
printchar ('\"', printcharfun);
}
/* Print a pseudovector that has no readable syntax. */
static void
print_vectorlike_unreadable (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag, char *buf)
{
/* First check whether this is handled by `print-unreadable-function'. */
if (!NILP (Vprint_unreadable_function)
&& FUNCTIONP (Vprint_unreadable_function))
{
@ -1697,7 +1690,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
if (STRINGP (result))
print_string (result, printcharfun);
/* It's handled, so stop processing here. */
return true;
return;
}
}
@ -1718,7 +1711,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
print_string (BVAR (XMARKER (obj)->buffer, name), printcharfun);
}
printchar ('>', printcharfun);
break;
return;
case PVEC_SYMBOL_WITH_POS:
{
@ -1742,7 +1735,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printchar ('>', printcharfun);
}
}
break;
return;
case PVEC_OVERLAY:
print_c_string ("#<overlay ", printcharfun);
@ -1758,7 +1751,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printcharfun);
}
printchar ('>', printcharfun);
break;
return;
case PVEC_USER_PTR:
{
@ -1769,14 +1762,14 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
strout (buf, i, i, printcharfun);
printchar ('>', printcharfun);
}
break;
return;
case PVEC_FINALIZER:
print_c_string ("#<finalizer", printcharfun);
if (NILP (XFINALIZER (obj)->function))
print_c_string (" used", printcharfun);
printchar ('>', printcharfun);
break;
return;
case PVEC_MISC_PTR:
{
@ -1785,7 +1778,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
int i = sprintf (buf, "#<ptr %p>", xmint_pointer (obj));
strout (buf, i, i, printcharfun);
}
break;
return;
case PVEC_PROCESS:
if (escapeflag)
@ -1796,13 +1789,13 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
else
print_string (XPROCESS (obj)->name, printcharfun);
break;
return;
case PVEC_SUBR:
print_c_string ("#<subr ", printcharfun);
print_c_string (XSUBR (obj)->symbol_name, printcharfun);
printchar ('>', printcharfun);
break;
return;
case PVEC_PACKAGE:
if (STRINGP (PACKAGE_NAMEX (obj)))
@ -1833,15 +1826,15 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
#endif
strout (buf, len, len, printcharfun);
}
break;
return;
}
#else
emacs_abort ();
#endif
break;
case PVEC_XWIDGET_VIEW:
print_c_string ("#<xwidget view", printcharfun);
printchar ('>', printcharfun);
break;
return;
case PVEC_WINDOW:
{
@ -1856,7 +1849,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
printchar ('>', printcharfun);
}
break;
return;
case PVEC_TERMINAL:
{
@ -1870,7 +1863,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
printchar ('>', printcharfun);
}
break;
return;
case PVEC_BUFFER:
if (!BUFFER_LIVE_P (XBUFFER (obj)))
@ -1883,11 +1876,11 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
else
print_string (BVAR (XBUFFER (obj), name), printcharfun);
break;
return;
case PVEC_WINDOW_CONFIGURATION:
print_c_string ("#<window-configuration>", printcharfun);
break;
return;
case PVEC_FRAME:
{
@ -1911,7 +1904,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
int len = sprintf (buf, " %p>", ptr);
strout (buf, len, len, printcharfun);
}
break;
return;
case PVEC_FONT:
{
@ -1944,7 +1937,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
printchar ('>', printcharfun);
}
break;
return;
case PVEC_THREAD:
print_c_string ("#<thread ", printcharfun);
@ -1957,7 +1950,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
strout (buf, len, len, printcharfun);
}
printchar ('>', printcharfun);
break;
return;
case PVEC_MUTEX:
print_c_string ("#<mutex ", printcharfun);
@ -1970,7 +1963,7 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
strout (buf, len, len, printcharfun);
}
printchar ('>', printcharfun);
break;
return;
case PVEC_CONDVAR:
print_c_string ("#<condvar ", printcharfun);
@ -1983,10 +1976,10 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
strout (buf, len, len, printcharfun);
}
printchar ('>', printcharfun);
break;
return;
#ifdef HAVE_MODULES
case PVEC_MODULE_FUNCTION:
#ifdef HAVE_MODULES
{
print_c_string ("#<module function ", printcharfun);
const struct Lisp_Module_Function *function = XMODULE_FUNCTION (obj);
@ -2011,11 +2004,13 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
printchar ('>', printcharfun);
return;
}
break;
#endif
#ifdef HAVE_NATIVE_COMP
break;
case PVEC_NATIVE_COMP_UNIT:
#ifdef HAVE_NATIVE_COMP
{
struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj);
print_c_string ("#<native compilation unit: ", printcharfun);
@ -2023,27 +2018,32 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printchar (' ', printcharfun);
print_object (cu->optimize_qualities, printcharfun, escapeflag);
printchar ('>', printcharfun);
return;
}
break;
#endif
break;
#ifdef HAVE_TREE_SITTER
case PVEC_TS_PARSER:
#ifdef HAVE_TREE_SITTER
print_c_string ("#<treesit-parser for ", printcharfun);
Lisp_Object language = XTS_PARSER (obj)->language_symbol;
/* No need to print the buffer because it's not that useful: we
usually know which buffer a parser belongs to. */
print_string (Fsymbol_name (language), printcharfun);
printchar ('>', printcharfun);
return;
#endif
break;
case PVEC_TS_NODE:
#ifdef HAVE_TREE_SITTER
/* Prints #<treesit-node (identifier) in 12-15> or
#<treesit-node "keyword" in 28-31>. */
print_c_string ("#<treesit-node", printcharfun);
if (!treesit_node_uptodate_p (obj))
{
print_c_string ("-outdated>", printcharfun);
break;
return;
}
printchar (' ', printcharfun);
/* Now the node must be up-to-date, and calling functions like
@ -2064,11 +2064,16 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
printchar ('-', printcharfun);
print_object (Ftreesit_node_end (obj), printcharfun, escapeflag);
printchar ('>', printcharfun);
break;
case PVEC_TS_COMPILED_QUERY:
print_c_string ("#<treesit-compiled-query>", printcharfun);
break;
return;
#endif
break;
case PVEC_TS_COMPILED_QUERY:
#ifdef HAVE_TREE_SITTER
print_c_string ("#<treesit-compiled-query>", printcharfun);
return;
#endif
break;
case PVEC_SQLITE:
{
@ -2084,13 +2089,23 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
print_c_string (XSQLITE (obj)->name, printcharfun);
printchar ('>', printcharfun);
}
return;
/* Types handled earlier. */
case PVEC_NORMAL_VECTOR:
case PVEC_RECORD:
case PVEC_COMPILED:
case PVEC_CHAR_TABLE:
case PVEC_SUB_CHAR_TABLE:
case PVEC_HASH_TABLE:
case PVEC_BIGNUM:
case PVEC_BOOL_VECTOR:
/* Impossible cases. */
case PVEC_FREE:
case PVEC_OTHER:
break;
default:
emacs_abort ();
}
return true;
emacs_abort ();
}
static char
@ -2597,29 +2612,21 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
switch (PSEUDOVECTOR_TYPE (XVECTOR (obj)))
{
case PVEC_NORMAL_VECTOR:
{
print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj),
printcharfun);
goto next_obj;
}
print_stack_push_vector ("[", "]", obj, 0, ASIZE (obj),
printcharfun);
goto next_obj;
case PVEC_RECORD:
{
print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj),
printcharfun);
goto next_obj;
}
print_stack_push_vector ("#s(", ")", obj, 0, PVSIZE (obj),
printcharfun);
goto next_obj;
case PVEC_COMPILED:
{
print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj),
printcharfun);
goto next_obj;
}
print_stack_push_vector ("#[", "]", obj, 0, PVSIZE (obj),
printcharfun);
goto next_obj;
case PVEC_CHAR_TABLE:
{
print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj),
printcharfun);
goto next_obj;
}
print_stack_push_vector ("#^[", "]", obj, 0, PVSIZE (obj),
printcharfun);
goto next_obj;
case PVEC_SUB_CHAR_TABLE:
{
/* Make each lowest sub_char_table start a new line.
@ -2688,30 +2695,22 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
goto next_obj;
}
case PVEC_BIGNUM:
print_bignum (obj, printcharfun);
break;
case PVEC_BOOL_VECTOR:
print_bool_vector (obj, printcharfun);
break;
default:
print_vectorlike_unreadable (obj, printcharfun, escapeflag, buf);
break;
}
if (print_vectorlike (obj, printcharfun, escapeflag, buf))
break;
FALLTHROUGH;
default:
{
int len;
/* We're in trouble if this happens!
Probably should just emacs_abort (). */
print_c_string ("#<EMACS BUG: INVALID DATATYPE ", printcharfun);
if (VECTORLIKEP (obj))
len = sprintf (buf, "(PVEC 0x%08zx)", (size_t) ASIZE (obj));
else
len = sprintf (buf, "(0x%02x)", (unsigned) XTYPE (obj));
strout (buf, len, len, printcharfun);
print_c_string ((" Save your buffers immediately"
" and please report this bug>"),
printcharfun);
break;
}
emacs_abort ();
}
print_depth--;

2
src/process.c
View file

@ -7212,6 +7212,8 @@ If PROCESS is a process object which contains the property
`remote-pid', or PROCESS is a number and REMOTE is a remote file name,
PROCESS is interpreted as process on the respective remote host, which
will be the process to signal.
If PROCESS is a string, it is interpreted as process object with the
respective process name, or as a number.
SIGCODE may be an integer, or a symbol whose name is a signal name. */)
(Lisp_Object process, Lisp_Object sigcode, Lisp_Object remote)
{

26
src/regex-emacs.c
View file

@ -2857,6 +2857,9 @@ forall_firstchar_1 (re_char *p, re_char *pend,
else
switch (*p)
{
case no_op:
p++; continue;
/* Cases which stop the iteration. */
case succeed:
case exactn:
@ -2872,15 +2875,9 @@ forall_firstchar_1 (re_char *p, re_char *pend,
/* Cases which may match the empty string. */
case at_dot:
case begbuf:
case no_op:
case wordbound:
case notwordbound:
case begline:
p++;
continue;
/* Cases which may match the empty string and may
tell us something about the next char. */
case endline:
case endbuf:
case wordbeg:
@ -3201,6 +3198,11 @@ analyze_first_fastmap (const re_char *p, void *arg)
}
return true;
case at_dot:
case begbuf:
case wordbound:
case notwordbound:
case begline:
case endline:
case endbuf:
case wordbeg:
@ -3244,6 +3246,11 @@ analyze_first_null (const re_char *p, void *arg)
case notcategoryspec:
return true;
case at_dot:
case begbuf:
case wordbound:
case notwordbound:
case begline:
case endline:
case endbuf:
case wordbeg:
@ -3983,6 +3990,13 @@ mutually_exclusive_one (re_char *p2, void *arg)
RETURN_CONSTRAIN (*data->p1 == syntaxspec
&& (data->p1[1] == Ssymbol || data->p1[1] == Sword));
case at_dot:
case begbuf:
case wordbound:
case notwordbound:
case begline:
RETURN_CONSTRAIN (false);
case duplicate:
/* At this point, we know nothing about what this can match, sadly. */
return false;

6
src/xdisp.c
View file

@ -18084,7 +18084,8 @@ set_cursor_from_row (struct window *w, struct glyph_row *row,
else if (dpos == 0)
match_with_avoid_cursor = true;
}
else if (STRINGP (glyph->object))
else if (STRINGP (glyph->object)
&& !glyph->avoid_cursor_p)
{
Lisp_Object chprop;
ptrdiff_t glyph_pos = glyph->charpos;
@ -18310,7 +18311,8 @@ set_cursor_from_row (struct window *w, struct glyph_row *row,
/* Any glyphs that come from the buffer are here because
of bidi reordering. Skip them, and only pay
attention to glyphs that came from some string. */
if (STRINGP (glyph->object))
if (STRINGP (glyph->object)
&& !glyph->avoid_cursor_p)
{
Lisp_Object str;
ptrdiff_t tem;

15
src/xfaces.c
View file

@ -3370,12 +3370,13 @@ FRAME 0 means change the face on all frames, and change the default
if (!CONSP (tem))
break;
v = XCAR (tem);
tem = XCDR (tem);
if (EQ (k, QCline_width))
{
if ((!CONSP(v) || !FIXNUMP (XCAR (v)) || XFIXNUM (XCAR (v)) == 0
|| !FIXNUMP (XCDR (v)) || XFIXNUM (XCDR (v)) == 0)
if ((!CONSP(v)
|| !FIXNUMP (XCAR (v))
|| XFIXNUM (XCAR (v)) == 0
|| !FIXNUMP (XCDR (v)) || XFIXNUM (XCDR (v)) == 0)
&& (!FIXNUMP (v) || XFIXNUM (v) == 0))
break;
}
@ -3386,12 +3387,16 @@ FRAME 0 means change the face on all frames, and change the default
}
else if (EQ (k, QCstyle))
{
if (!EQ (v, Qpressed_button) && !EQ (v, Qreleased_button)
&& !EQ(v, Qflat_button))
if (!NILP (v)
&& !EQ (v, Qpressed_button)
&& !EQ (v, Qreleased_button)
&& !EQ (v, Qflat_button))
break;
}
else
break;
tem = XCDR (tem);
}
valid_p = NILP (tem);

184
test/lisp/completion-preview-tests.el Normal file
View file

@ -0,0 +1,184 @@
;;; completion-preview-tests.el --- tests for completion-preview.el -*- lexical-binding: t -*-
;; Copyright (C) 2023 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
(require 'ert)
(require 'completion-preview)
(defun completion-preview-tests--capf (completions &rest props)
(lambda ()
(when-let ((bounds (bounds-of-thing-at-point 'symbol)))
(append (list (car bounds) (cdr bounds) completions) props))))
(defun completion-preview-tests--check-preview (string &optional exact)
"Check that the completion preview is showing STRING.
If EXACT is non-nil, check that STRING has the
`completion-preview-exact' face. Otherwise check that STRING has
the `completion-preview' face.
If STRING is nil, check that there is no completion preview
instead."
(if (not string)
(should (not completion-preview--overlay))
(should completion-preview--overlay)
(let ((after-string (completion-preview--get 'after-string)))
(should (string= after-string string))
(should (eq (get-text-property 0 'face after-string)
(if exact
'completion-preview-exact
'completion-preview))))))
(ert-deftest completion-preview ()
"Test Completion Preview mode."
(with-temp-buffer
(setq-local completion-at-point-functions
(list (completion-preview-tests--capf '("foobarbaz"))))
(insert "foo")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
;; Exact match
(completion-preview-tests--check-preview "barbaz" 'exact)
(insert "v")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
;; No match, no preview
(completion-preview-tests--check-preview nil)
(delete-char -1)
(let ((this-command 'delete-backward-char))
(completion-preview--post-command))
;; Exact match again
(completion-preview-tests--check-preview "barbaz" 'exact)))
(ert-deftest completion-preview-multiple-matches ()
"Test Completion Preview mode with multiple matching candidates."
(with-temp-buffer
(setq-local completion-at-point-functions
(list (completion-preview-tests--capf
'("foobar" "foobaz"))))
(insert "foo")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
;; Multiple matches, the preview shows the first one
(completion-preview-tests--check-preview "bar")
(completion-preview-next-candidate 1)
;; Next match
(completion-preview-tests--check-preview "baz")))
(ert-deftest completion-preview-exact-match-only ()
"Test `completion-preview-exact-match-only'."
(with-temp-buffer
(setq-local completion-at-point-functions
(list (completion-preview-tests--capf
'("spam" "foobar" "foobaz")))
completion-preview-exact-match-only t)
(insert "foo")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
;; Multiple matches, so no preview
(completion-preview-tests--check-preview nil)
(delete-region (point-min) (point-max))
(insert "spa")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
;; Exact match
(completion-preview-tests--check-preview "m" 'exact)))
(ert-deftest completion-preview-function-capfs ()
"Test Completion Preview mode with capfs that return a function."
(with-temp-buffer
(setq-local completion-at-point-functions
(list
(lambda () #'ignore)
(completion-preview-tests--capf
'("foobar" "foobaz"))))
(insert "foo")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
(completion-preview-tests--check-preview "bar")))
(ert-deftest completion-preview-non-exclusive-capfs ()
"Test Completion Preview mode with non-exclusive capfs."
(with-temp-buffer
(setq-local completion-at-point-functions
(list
(completion-preview-tests--capf
'("spam") :exclusive 'no)
(completion-preview-tests--capf
'("foobar" "foobaz") :exclusive 'no)
(completion-preview-tests--capf
'("foobarbaz"))))
(insert "foo")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
(completion-preview-tests--check-preview "bar")
(setq-local completion-preview-exact-match-only t)
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
(completion-preview-tests--check-preview "barbaz" 'exact)))
(ert-deftest completion-preview-face-updates ()
"Test updating the face in completion preview when match is no longer exact."
(with-temp-buffer
(setq-local completion-at-point-functions
(list
(completion-preview-tests--capf
'("foobarbaz" "food"))))
(insert "foo")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
(completion-preview-tests--check-preview "d")
(insert "b")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
(completion-preview-tests--check-preview "arbaz" 'exact)
(delete-char -1)
(let ((this-command 'delete-backward-char))
(completion-preview--post-command))
(completion-preview-tests--check-preview "d")))
(ert-deftest completion-preview-capf-errors ()
"Test Completion Preview mode with capfs that signal errors.
`dabbrev-capf' is one example of such a capf."
(with-temp-buffer
(setq-local completion-at-point-functions
(list
(lambda () (user-error "bad"))
(completion-preview-tests--capf
'("foobarbaz"))))
(insert "foo")
(let ((this-command 'self-insert-command))
(completion-preview--post-command))
(completion-preview-tests--check-preview "barbaz" 'exact)))
;;; completion-preview-tests.el ends here

21
test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
View file

@ -1046,6 +1046,27 @@ Subclasses to override slot attributes."))
(should (eq (eieio-test--struct-a x) 1))
(should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only)))
(defclass foo-bug-66938 (eieio-instance-inheritor)
((x :initarg :x
:accessor ref-x
:reader get-x))
"A class to test that delegation occurs under certain
circumstances when using an accessor function, as it would when
using the reader function.")
(ert-deftest eieio-test-use-accessor-function-with-cloned-object ()
"The class FOO-BUG-66938 is a subclass of
`eieio-instance-inheritor'. Therefore, given an instance OBJ1 of
FOO-BUG-66938, and a clone (OBJ2), OBJ2 should delegate to OBJ1
when accessing an unbound slot.
In particular, its behavior should be identical to that of the
reader function, when reading a slot."
(let* ((obj1 (foo-bug-66938 :x 4))
(obj2 (clone obj1)))
(should (eql (ref-x obj2) 4))
(should (eql (get-x obj2) (ref-x obj2)))))
(provide 'eieio-tests)
;;; eieio-tests.el ends here

2
test/lisp/erc/erc-scenarios-auth-source.el
View file

@ -56,7 +56,7 @@
(should (string= (buffer-name) (if id
(symbol-name id)
(format "127.0.0.1:%d" port))))
(erc-d-t-wait-for 5 (eq erc-network 'FooNet))))))
(erc-d-t-wait-for 10 (eq erc-network 'FooNet))))))
(ert-deftest erc-scenarios-base-auth-source-server--dialed ()
:tags '(:expensive-test)

2
test/lisp/erc/erc-scenarios-base-buffer-display.el
View file

@ -193,7 +193,7 @@
(lambda (_)
(with-current-buffer "FooNet"
(should erc--server-reconnect-display-timer))
(erc-d-t-wait-for 1 erc--server-reconnect-display-timer))
;; A non-interactive JOIN command doesn't signal that we're
;; done auto-reconnecting.

2
test/lisp/erc/erc-scenarios-base-renick.el
View file

@ -173,7 +173,7 @@
(with-current-buffer erc-server-buffer-foo
(should (string= (buffer-name) (format "127.0.0.1:%d" port)))))
(erc-d-t-wait-for 1 (get-buffer "foonet"))
(erc-d-t-wait-for 10 (get-buffer "foonet"))
(ert-info ("Joined by bouncer to #foo, pal persent")
(with-current-buffer (erc-d-t-wait-for 1 (get-buffer "#foo"))

3
test/lisp/erc/erc-scenarios-display-message.el
View file

@ -57,6 +57,7 @@
(funcall expect 10 "*** dummy (~u@rdjcgiwfuwqmc.irc) has quit")
(should (eq 'QUIT (get-text-property (match-beginning 0) 'erc-msg)))))
(erc-cmd-QUIT "")))
(with-current-buffer "foonet"
(erc-cmd-QUIT ""))))
;;; erc-scenarios-display-message.el ends here

2
test/lisp/erc/erc-scenarios-misc.el
View file

@ -75,7 +75,7 @@
(ert-info ("All output sent")
(with-current-buffer "#chan/foonet"
(funcall expect 8 "Some man or other"))
(funcall expect 16 "Some man or other"))
(with-current-buffer "#chan/barnet"
(funcall expect 10 "That's he that was Othello")))))

53
test/lisp/erc/erc-tests.el
View file

@ -155,7 +155,9 @@
(set-process-query-on-exit-flag erc-server-process nil))
(ert-deftest erc-hide-prompt ()
(let (erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
(let ((erc-hide-prompt erc-hide-prompt)
;;
erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
(with-current-buffer (get-buffer-create "ServNet")
(erc-tests--send-prep)
@ -812,6 +814,8 @@
(should-not calls))))
(ert-deftest erc--channel-modes ()
:tags (and (null (getenv "CI")) '(:unstable))
(setq erc--isupport-params (make-hash-table)
erc--target (erc--target-from-string "#test")
erc-server-parameters
@ -827,15 +831,25 @@
(should (equal (erc--channel-modes) '((?k . "h2") (?l . "3") (?t))))
(should (equal (erc--channel-modes 3 ",") "klt h2,3"))
;; The function this tests behaves differently in different
;; environments. For example, on one GNU Linux system, it returns
;; truncation ellipsis when run interactively. Rather than have
;; hard-to-read "nondeterministic" comparisons against sets of
;; acceptable values, we use separate tests.
(when (display-graphic-p) (ert-pass))
;; Truncation cache populated and used.
(let ((cache (erc--channel-mode-types-shortargs erc--channel-mode-types))
first-run)
(should (zerop (hash-table-count cache)))
(should (equal (erc--channel-modes 1 ",") "klt h,3"))
(should (equal (setq first-run (map-pairs cache)) '(((1 ?k "h2") . "h"))))
;; Second call uses cache.
(cl-letf (((symbol-function 'truncate-string-to-width)
(lambda (&rest _) (ert-fail "Shouldn't run"))))
(should (equal (erc--channel-modes 1 ",") "klt h,3")))
;; Same key for only entry matches that of first result.
(should (pcase (map-pairs cache)
((and '(((1 ?k "h2") . "h")) second-run)
@ -847,6 +861,43 @@
(should (equal (erc--channel-modes 1) "klt h 3"))
(should (equal (erc--channel-modes 0) "klt "))) ; 2 spaces
(ert-deftest erc--channel-modes/graphic-p ()
:tags '(:unstable)
(unless (display-graphic-p) (ert-skip "See non-/graphic-p variant"))
(erc-tests--set-fake-server-process "sleep" "1")
(setq erc--isupport-params (make-hash-table)
erc--target (erc--target-from-string "#test")
erc-server-parameters
'(("CHANMODES" . "eIbq,k,flj,CFLMPQRSTcgimnprstuz")))
(cl-letf (((symbol-function 'erc-update-mode-line) #'ignore))
(erc--update-channel-modes "+bltk" "fool!*@*" "3" "hun2"))
;; Truncation cache populated and used.
(let ((cache (erc--channel-mode-types-shortargs erc--channel-mode-types))
first-run)
(should (zerop (hash-table-count cache)))
(should (equal (erc--channel-modes 2 ",") "klt h…,3" ))
(should (equal (setq first-run (map-pairs cache))
'(((2 ?k "hun2") . "h…"))))
;; Second call uses cache.
(cl-letf (((symbol-function 'truncate-string-to-width)
(lambda (&rest _) (ert-fail "Shouldn't run"))))
(should (equal (erc--channel-modes 2 ",") "klt h…,3" )))
;; Same key for only entry matches that of first result.
(should (pcase (map-pairs cache)
((and `(((2 ?k "hun2") . "h…")) second-run)
(eq (pcase first-run (`((,k . ,_)) k))
(pcase second-run (`((,k . ,_)) k)))))))
;; A max length of 0 is nonsensical anyway, so skip those.
(should (equal (erc--channel-modes 3) "klt hu… 3"))
(should (equal (erc--channel-modes 2) "klt h… 3"))
(should (equal (erc--channel-modes 1) "klt … 3")))
(ert-deftest erc--update-user-modes ()
(let ((erc--user-modes (list ?a)))
(should (equal (erc--update-user-modes "+a") '(?a)))

6
test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld
View file

@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
((pass 1 "PASS :barnet:changeme"))
((nick 1 "NICK tester"))
((user 2 "USER user 0 * :tester")
((pass 10 "PASS :barnet:changeme"))
((nick 10 "NICK tester"))
((user 10 "USER user 0 * :tester")
(0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester")
(0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.barnet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC")

6
test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld
View file

@ -1,7 +1,7 @@
;; -*- mode: lisp-data; -*-
((pass 1 "PASS :foonet:changeme"))
((nick 1 "NICK tester"))
((user 1 "USER user 0 * :tester")
((pass 10 "PASS :foonet:changeme"))
((nick 10 "NICK tester"))
((user 10 "USER user 0 * :tester")
(0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
(0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16")
(0 ":irc.foonet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC")

23
test/lisp/erc/resources/erc-scenarios-common.el
View file

@ -654,10 +654,17 @@ Bug#48598: 28.0.50; buffer-naming collisions involving bouncers in ERC."
(with-current-buffer erc-server-buffer-foo (erc-cmd-JOIN "#chan"))
(with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan"))
(funcall expect 5 "vile thing")
(erc-cmd-QUIT "")))
(erc-cmd-QUIT "")
(erc-d-t-wait-for 2 "Foonet connection deceased"
(not (erc-server-process-alive erc-server-buffer-foo)))
(ert-info ("Prompt hidden in channel buffer upon quitting")
(erc-d-t-wait-for 10 (erc--prompt-hidden-p))
(should (overlays-in erc-insert-marker erc-input-marker)))))
(with-current-buffer erc-server-buffer-foo
(ert-info ("Prompt hidden after process dies in server buffer")
(erc-d-t-wait-for 2 (not (erc-server-process-alive)))
(erc-d-t-wait-for 10 (erc--prompt-hidden-p))
(should (overlays-in erc-insert-marker erc-input-marker))))
(should (equal erc-autojoin-channels-alist
(if foo-id '((oofnet "#chan")) '((foonet "#chan")))))
@ -706,6 +713,10 @@ Bug#48598: 28.0.50; buffer-naming collisions involving bouncers in ERC."
(setq erc-server-process-foo erc-server-process)
(erc-d-t-wait-for 2 (eq erc-network 'foonet))
(should (string= (buffer-name) (if foo-id "oofnet" "foonet")))
(ert-info ("Prompt unhidden")
(should-not (erc--prompt-hidden-p))
(should-not (overlays-in erc-insert-marker erc-input-marker)))
(funcall expect 5 "foonet")))
(ert-info ("#chan@foonet is clean, no cross-contamination")
@ -713,7 +724,11 @@ Bug#48598: 28.0.50; buffer-naming collisions involving bouncers in ERC."
(erc-d-t-wait-for 3 (eq erc-server-process erc-server-process-foo))
(funcall expect 3 "<bob>")
(erc-d-t-absent-for 0.1 "<joe>")
(funcall expect 20 "not given me")))
(funcall expect 30 "not given me")
(ert-info ("Prompt unhidden")
(should-not (erc--prompt-hidden-p))
(should-not (overlays-in erc-insert-marker erc-input-marker)))))
(ert-info ("All #chan@barnet output received")
(with-current-buffer chan-buf-bar

3
test/lisp/net/dbus-tests.el
View file

@ -465,6 +465,9 @@
(should (eq (dbus-unregister-service bus dbus--test-service) :non-existent))
(should-not (member dbus--test-service (dbus-list-known-names bus)))
;; Unregistering a unique name returns nil.
(should-not (dbus-unregister-service bus ":1.1"))
;; A service name is a string, constructed of at least two words
;; separated by ".".
(should

106
test/lisp/net/tramp-tests.el
View file

@ -5684,55 +5684,69 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
(delete-exited-processes t)
kill-buffer-query-functions command proc)
(dolist (sigcode '(2 INT))
(unwind-protect
(with-temp-buffer
(setq command "trap 'echo boom; exit 1' 2; sleep 100"
proc (start-file-process-shell-command
(format "test1%s" sigcode) (current-buffer) command))
(should (processp proc))
(should (process-live-p proc))
(should (equal (process-status proc) 'run))
(should (numberp (process-get proc 'remote-pid)))
(should (equal (process-get proc 'remote-command)
(with-connection-local-variables
`(,shell-file-name ,shell-command-switch ,command))))
(should (zerop (signal-process proc sigcode)))
;; Let the process accept the signal.
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output proc 0 nil t)))
(should-not (process-live-p proc)))
;; If PROCESS is a string, it must be a process name or a process
;; number. Check error handling.
(should-error
(signal-process (md5 (current-time-string)) 0)
:type 'wrong-type-argument)
;; Cleanup.
(ignore-errors (kill-process proc))
(ignore-errors (delete-process proc)))
(unwind-protect
(with-temp-buffer
(setq command "trap 'echo boom; exit 1' 2; sleep 100"
proc (start-file-process-shell-command
(format "test2%s" sigcode) (current-buffer) command))
(should (processp proc))
(should (process-live-p proc))
(should (equal (process-status proc) 'run))
(should (numberp (process-get proc 'remote-pid)))
(should (equal (process-get proc 'remote-command)
(with-connection-local-variables
`(,shell-file-name ,shell-command-switch ,command))))
;; `signal-process' has argument REMOTE since Emacs 29.
(with-no-warnings
;; The PROCESS argument of `signal-process' can be a string. Test
;; this as well.
(dolist
(func '(identity
(lambda (x) (format "%s" (if (processp x) (process-name x) x)))))
(dolist (sigcode '(2 INT))
(unwind-protect
(with-temp-buffer
(setq command "trap 'echo boom; exit 1' 2; sleep 100"
proc (start-file-process-shell-command
(format "test1-%s" sigcode) (current-buffer) command))
(should (processp proc))
(should (process-live-p proc))
(should (equal (process-status proc) 'run))
(should (numberp (process-get proc 'remote-pid)))
(should
(zerop
(signal-process
(process-get proc 'remote-pid) sigcode default-directory))))
;; Let the process accept the signal.
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output proc 0 nil t)))
(should-not (process-live-p proc)))
(equal (process-get proc 'remote-command)
(with-connection-local-variables
`(,shell-file-name ,shell-command-switch ,command))))
(should (zerop (signal-process (funcall func proc) sigcode)))
;; Let the process accept the signal.
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output proc 0 nil t)))
(should-not (process-live-p proc)))
;; Cleanup.
(ignore-errors (kill-process proc))
(ignore-errors (delete-process proc))))))
;; Cleanup.
(ignore-errors (kill-process proc))
(ignore-errors (delete-process proc)))
(unwind-protect
(with-temp-buffer
(setq command "trap 'echo boom; exit 1' 2; sleep 100"
proc (start-file-process-shell-command
(format "test2-%s" sigcode) (current-buffer) command))
(should (processp proc))
(should (process-live-p proc))
(should (equal (process-status proc) 'run))
(should (numberp (process-get proc 'remote-pid)))
(should
(equal (process-get proc 'remote-command)
(with-connection-local-variables
`(,shell-file-name ,shell-command-switch ,command))))
;; `signal-process' has argument REMOTE since Emacs 29.
(with-no-warnings
(should
(zerop
(signal-process
(funcall func (process-get proc 'remote-pid))
sigcode default-directory))))
;; Let the process accept the signal.
(with-timeout (10 (tramp--test-timeout-handler))
(while (accept-process-output proc 0 nil t)))
(should-not (process-live-p proc)))
;; Cleanup.
(ignore-errors (kill-process proc))
(ignore-errors (delete-process proc)))))))
(ert-deftest tramp-test31-list-system-processes ()
"Check `list-system-processes'."

20
test/lisp/progmodes/c-ts-mode-resources/indent.erts
View file

@ -149,6 +149,21 @@ for (int i = 0;
Name: Bracketless Simple Statement
=-=
for (int i = 0; i < 5; i++)
continue;
while (true)
return 1;
do
i++;
while (true)
if (true)
break;
else
break;
=-=
for (int i = 0; i < 5; i++)
continue;
@ -159,6 +174,11 @@ while (true)
do
i++;
while (true)
if (true)
break;
else
break;
=-=-=
Name: Nested If-Else

17
test/lisp/progmodes/typescript-ts-mode-resources/indent.erts
View file

@ -45,6 +45,23 @@ const foo = () => {
};
=-=-=
Name: Switch statement
=-=
const foo = (x: string) => {
switch (x) {
case "a":
console.log(x);
return 1;
case "b":
return 2;
case "c":
default:
return 0;
}
};
=-=-=
Code:
(lambda ()
(setq indent-tabs-mode nil)

43
test/lisp/register-tests.el
View file

@ -1,43 +0,0 @@
;;; register-tests.el --- tests for register.el -*- lexical-binding: t-*-
;; Copyright (C) 2017-2023 Free Software Foundation, Inc.
;; Author: Tino Calancha <tino.calancha@gmail.com>
;; Keywords:
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert)
(require 'cl-lib)
(ert-deftest register-test-bug27634 ()
"Test for https://debbugs.gnu.org/27634 ."
(dolist (event (list ?\C-g 'escape ?\C-\[))
(cl-letf (((symbol-function 'read-key) #'ignore)
(last-input-event event)
(register-alist nil))
(should (equal 'quit
(condition-case err
(call-interactively 'point-to-register)
(quit (car err)))))
(should-not register-alist))))
(provide 'register-tests)
;;; register-tests.el ends here