[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/pkg 5db5f285f0f: Merge remote-tracking branch 'origin/master' in
|
From: |
Gerd Moellmann |
|
Subject: |
scratch/pkg 5db5f285f0f: Merge remote-tracking branch 'origin/master' into scratch/pkg |
|
Date: |
Fri, 10 Nov 2023 11:05:10 -0500 (EST) |
branch: scratch/pkg
commit 5db5f285f0f9354a34820b9adce4fb294adc9d78
Merge: ec4bdca4924 dfcc9a0f4d6
Author: Gerd Möllmann <gerd@gnu.org>
Commit: Gerd Möllmann <gerd@gnu.org>
Merge remote-tracking branch 'origin/master' into scratch/pkg
---
admin/MAINTAINERS | 2 +
admin/authors.el | 2 +-
doc/emacs/programs.texi | 7 +
doc/lispref/frames.texi | 9 +-
doc/lispref/parsing.texi | 18 +-
doc/lispref/tips.texi | 15 +
doc/man/emacsclient.1 | 4 +-
doc/misc/efaq.texi | 43 +-
doc/misc/eglot.texi | 37 +-
doc/misc/tramp.texi | 2 +-
etc/NEWS | 130 ++-
java/org/gnu/emacs/EmacsNative.java | 7 +
java/org/gnu/emacs/EmacsService.java | 24 +
lisp/Makefile.in | 2 +
lisp/bookmark.el | 2 +
lisp/calc/calc.el | 2 +
lisp/dired-aux.el | 2 +-
lisp/dired.el | 40 +-
lisp/emacs-lisp/advice.el | 2 +-
lisp/emacs-lisp/cl-extra.el | 15 +-
lisp/emacs-lisp/cl-generic.el | 2 +-
lisp/emacs-lisp/cl-lib.el | 10 +-
lisp/emacs-lisp/cl-macs.el | 7 +-
lisp/emacs-lisp/comp-common.el | 553 +++++++++++
lisp/emacs-lisp/comp-cstr.el | 28 +-
lisp/emacs-lisp/comp-run.el | 459 +++++++++
lisp/emacs-lisp/comp.el | 1008 +-------------------
lisp/emacs-lisp/ert.el | 2 +-
lisp/emacs-lisp/nadvice.el | 4 +-
lisp/emacs-lisp/oclosure.el | 1 +
lisp/emacs-lisp/warnings.el | 1 +
lisp/erc/erc-stamp.el | 192 ++--
lisp/erc/erc.el | 16 +-
lisp/icomplete.el | 8 +-
lisp/mail/smtpmail.el | 4 +-
lisp/man.el | 159 ++-
lisp/minibuffer.el | 442 ++++++---
lisp/net/browse-url.el | 2 +-
lisp/net/eww.el | 2 +-
lisp/net/nsm.el | 8 +-
lisp/progmodes/cperl-mode.el | 86 +-
lisp/progmodes/eglot.el | 17 +-
lisp/progmodes/elisp-mode.el | 2 +-
lisp/progmodes/js.el | 9 -
lisp/progmodes/project.el | 138 ++-
lisp/progmodes/ruby-ts-mode.el | 4 +-
lisp/saveplace.el | 4 +-
lisp/simple.el | 145 ++-
lisp/term/android-win.el | 76 +-
lisp/treesit.el | 180 +++-
lisp/vc/vc-git.el | 2 +-
src/Makefile.in | 2 +
src/alloc.c | 26 +-
src/android.c | 67 ++
src/androidterm.c | 13 +-
src/keyboard.c | 27 +-
src/sfnt.c | 78 ++
src/sfnt.h | 48 +
src/sfntfont.c | 76 +-
src/xdisp.c | 88 +-
test/infra/gitlab-ci.yml | 4 +-
test/lisp/emacs-lisp/bytecomp-tests.el | 3 +-
test/lisp/erc/erc-fill-tests.el | 21 +-
test/lisp/erc/erc-scenarios-base-association.el | 2 +-
test/lisp/erc/erc-scenarios-base-buffer-display.el | 104 +-
.../erc/erc-scenarios-base-misc-regressions.el | 4 +-
test/lisp/erc/erc-scenarios-stamp.el | 65 ++
test/lisp/erc/erc-tests.el | 49 +
.../erc/resources/base/local-modules/second.eld | 2 +-
.../erc/resources/base/local-modules/third.eld | 2 +-
.../erc/resources/base/reconnect/options-again.eld | 4 +-
test/lisp/erc/resources/dcc/chat/accept.eld | 2 +-
test/lisp/erc/resources/erc-d/erc-d.el | 2 +-
.../resources/erc-d/resources/dynamic-foonet.eld | 2 +-
test/lisp/erc/resources/erc-scenarios-common.el | 2 +-
.../resources/fill/snapshots/merge-01-start.eld | 2 +-
.../resources/fill/snapshots/merge-02-right.eld | 2 +-
.../erc/resources/fill/snapshots/merge-wrap-01.eld | 2 +-
test/lisp/files-tests.el | 151 +++
test/lisp/mh-e/test-all-mh-variants.sh | 4 +-
test/lisp/minibuffer-tests.el | 90 ++
test/lisp/time-stamp-tests.el | 32 +-
test/src/comp-resources/comp-test-funcs.el | 4 +
test/src/comp-tests.el | 30 +-
test/src/treesit-tests.el | 7 +
85 files changed, 3250 insertions(+), 1703 deletions(-)
diff --git a/admin/MAINTAINERS b/admin/MAINTAINERS
index a6e1baf85e1..f59c684e81f 100644
--- a/admin/MAINTAINERS
+++ b/admin/MAINTAINERS
@@ -133,6 +133,8 @@ Andrea Corallo
Lisp native compiler
src/comp.c
lisp/emacs-lisp/comp.el
+ lisp/emacs-lisp/comp-common.el
+ lisp/emacs-lisp/comp-run.el
lisp/emacs-lisp/comp-cstr.el
test/src/comp-*.el
diff --git a/admin/authors.el b/admin/authors.el
index 679ddf08085..2108f481a0c 100644
--- a/admin/authors.el
+++ b/admin/authors.el
@@ -78,7 +78,7 @@ files.")
("David M. Koppelman" "David Koppelman")
("David M. Smith" "David Smith" "David M Smith")
("David O'Toole" "David T. O'Toole")
- (nil "dalanicolai")
+ ("Daniel Laurens Nicolai" "dalanicolai")
(nil "deech@deech")
("Deepak Goel" "D. Goel")
("Earl Hyatt" "Earl" "ej32u@protonmail.com")
diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi
index 40746e03ecc..7746bc8bc23 100644
--- a/doc/emacs/programs.texi
+++ b/doc/emacs/programs.texi
@@ -1402,6 +1402,13 @@ asynchronously. You can force the invocation to be
synchronous by
customizing @code{Man-prefer-synchronous-calls} to a non-@code{nil}
value.
+@vindex Man-support-remote-systems
+ If the user option @code{Man-support-remote-systems} is
+non-@code{nil}, and @code{default-directory} indicates a remote system
+(@pxref{Remote Files}), the man page is taken from the remote system.
+Calling the @code{man} command with a prefix like @kbd{C-u M-x man}
+reverts the value of @code{Man-support-remote-systems} for that call.
+
@findex woman
@cindex manual pages, on MS-DOS/MS-Windows
An alternative way of reading manual pages is the @kbd{M-x woman}
diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi
index 6193a4fe1cd..ca8c79395ed 100644
--- a/doc/lispref/frames.texi
+++ b/doc/lispref/frames.texi
@@ -4686,15 +4686,18 @@ of available selection data types, as elsewhere.
@cindex Android selections
Much like MS-Windows, Android provides a clipboard but no primary or
secondary selection; @code{gui-set-selection} simulates the primary
-selection by saving the value supplied into a variable subsequent
-calls to @code{gui-get-selection} return.
+and secondary selections by saving the value supplied into a variable
+subsequent calls to @code{gui-get-selection} return.
From the clipboard, @code{gui-get-selection} is capable of returning
UTF-8 string data of the type @code{STRING}, the @code{TAREGTS} data
type, or image and application data of any MIME type.
@code{gui-set-selection} sets only string data, much as under
MS-Windows, although this data is not affected by the value of
-@code{selection-coding-system}.
+@code{selection-coding-system}. By contrast, only string data can be
+saved to and from the primary and secondary selections; but since this
+data is not communicated to programs besides Emacs, it is not subject
+to encoding or decoding by any coding system.
@node Yanking Media
@section Yanking Media
diff --git a/doc/lispref/parsing.texi b/doc/lispref/parsing.texi
index bac5a864bf8..df81a805e67 100644
--- a/doc/lispref/parsing.texi
+++ b/doc/lispref/parsing.texi
@@ -705,7 +705,7 @@ This function finds the previous sibling of @var{node}. If
To make the syntax tree easier to analyze, many language grammars
assign @dfn{field names} to child nodes (@pxref{tree-sitter node field
name, field name}). For example, a @code{function_definition} node
-could have a @code{declarator} node and a @code{body} node.
+could have a @code{declarator} child and a @code{body} child.
@defun treesit-node-child-by-field-name node field-name
This function finds the child of @var{node} whose field name is
@@ -1081,6 +1081,22 @@ This function returns the number of children of
@var{node}. If
(@pxref{tree-sitter named node, named node}).
@end defun
+@heading Convenience functions
+
+@defun treesit-node-enclosed-p smaller larger &optional strict
+This function returns non-@code{nil} if @var{smaller} is enclosed in
+@var{larger}. @var{smaller} and @var{larger} can be either a cons
+@code{(@var{beg} . @var{end})} or a node.
+
+Return non-@code{nil} if @var{larger}'s start <= @var{smaller}'s start
+and @var{larger}'s end <= @var{smaller}'s end.
+
+If @var{strict} is @code{t}, compare with < rather than <=.
+
+If @var{strict} is @code{partial}, consider @var{larger} encloses
+@var{smaller} when at least one side is strictly enclosing.
+@end defun
+
@node Pattern Matching
@section Pattern Matching Tree-sitter Nodes
@cindex pattern matching with tree-sitter nodes
diff --git a/doc/lispref/tips.texi b/doc/lispref/tips.texi
index 6128fef5d99..81a5e1688fd 100644
--- a/doc/lispref/tips.texi
+++ b/doc/lispref/tips.texi
@@ -1169,6 +1169,21 @@ element) is equivalent to entry with version "0". For
instance:
;; Package-Requires: ((gnus "1.0") (bubbles "2.7.2") cl-lib (seq))
@end smallexample
+Packages that don't need to support Emacs versions older than Emacs 27
+can have the @samp{Package-Requires} header split across multiple
+lines, like this:
+
+@smallexample
+@group
+;; Package-Requires: ((emacs "27.1")
+;; (compat "29.1.4.1"))
+@end group
+@end smallexample
+
+@noindent
+Note that with this format, you still need to start the list on the
+same line as @samp{Package-Requires}.
+
The package code automatically defines a package named @samp{emacs}
with the version number of the currently running Emacs. This can be
used to require a minimal version of Emacs for a package.
diff --git a/doc/man/emacsclient.1 b/doc/man/emacsclient.1
index acc2edd4609..0acf3dd339e 100644
--- a/doc/man/emacsclient.1
+++ b/doc/man/emacsclient.1
@@ -1,5 +1,5 @@
.\" See section COPYING for conditions for redistribution.
-.TH EMACSCLIENT 1 "2023-10-16" "GNU Emacs" "GNU"
+.TH EMACSCLIENT 1 "2023-10-25" "GNU Emacs" "GNU"
.\" NAME should be all caps, SECTION should be 1-8, maybe w/ subsection
.\" other params are allowed: see man(7), man(1)
.SH NAME
@@ -119,7 +119,7 @@ This can also be specified via the EMACS_SOCKET_NAME
environment variable.
.B \-nw, \-t, \-\-tty
Open a new Emacs frame on the current terminal.
.TP
-.B \-T, \-\-tramp-prefix=PREFIX
+.B \-T, \-\-tramp=PREFIX
Set PREFIX to add to filenames for Emacs to locate files on remote
machines using TRAMP. This is mostly useful in combination with using
the Emacs server over TCP with --server-file. This can also be
diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi
index 631d7016acf..70f434d4b99 100644
--- a/doc/misc/efaq.texi
+++ b/doc/misc/efaq.texi
@@ -1721,7 +1721,7 @@ is better to write ``Emacs and XEmacs.''
* Editing MS-DOS files::
* Filling paragraphs with a single space::
* Escape sequences in shell output::
-* Fullscreen mode on MS-Windows::
+* Start Emacs maximized::
* Emacs in a Linux console::
@end menu
@@ -3113,45 +3113,22 @@ prints using ANSI color escape sequences. Emacs
includes the
@code{ansi-color} package, which lets Shell mode recognize these
escape sequences. It is enabled by default.
-@node Fullscreen mode on MS-Windows
-@section How can I start Emacs in fullscreen mode on MS-Windows?
+@node Start Emacs maximized
+@section How can I start Emacs in full screen?
@cindex Maximize frame
@cindex Fullscreen mode
-Beginning with Emacs 24.4 either run Emacs with the @samp{--maximized}
-command-line option or put the following form in your init file
-(@pxref{Setting up a customization file}):
-
-@lisp
-(add-hook 'emacs-startup-hook 'toggle-frame-maximized)
-@end lisp
-
-With older versions use the function @code{w32-send-sys-command}. For
-example, you can put the following in your init file:
-
-@lisp
-(add-hook 'emacs-startup-hook
- (lambda () (w32-send-sys-command ?\xF030)))
-@end lisp
-
-To avoid the slightly distracting visual effect of Emacs starting with
-its default frame size and then growing to fullscreen, you can add an
-@samp{Emacs.Geometry} entry to the Windows Registry settings. @xref{X
-Resources,,, emacs, The GNU Emacs Manual}. To compute the correct
-values for width and height you use in the Registry settings, first
-maximize the Emacs frame and then evaluate @code{(frame-height)} and
-@code{(frame-width)} with @kbd{M-:}.
-
-Alternatively, you can avoid the visual effect of Emacs changing its
-frame size entirely in your init file (i.e., without using the
-Registry), like this:
+Run Emacs with the @samp{--maximized} command-line option or put the
+following form in your early init file (@pxref{Early Init File,,,
+emacs, The GNU Emacs Manual}).
@lisp
-(setq frame-resize-pixelwise t)
-(set-frame-position nil 0 0)
-(set-frame-size nil (display-pixel-width) (display-pixel-height) t)
+(push '(fullscreen . maximized) default-frame-alist)
@end lisp
+Note that while some customizations of @code{default-frame-alist}
+could have undesirable effects when modified in @file{early-init.el},
+it is okay to do it in this particular case.
@node Emacs in a Linux console
@section How can I alleviate the limitations of the Linux console?
diff --git a/doc/misc/eglot.texi b/doc/misc/eglot.texi
index 3c1d44cd363..2d9b2a2b60e 100644
--- a/doc/misc/eglot.texi
+++ b/doc/misc/eglot.texi
@@ -139,16 +139,19 @@ To start using Eglot for a project, type @kbd{M-x eglot
@key{RET}} in
a buffer visiting any file that belongs to the project. This starts
the language server configured for the programming language of that
buffer, and causes Eglot to start managing all the files of the
-project which use the same programming language. The notion of a
-``project'' used by Eglot is the same Emacs uses (@pxref{Projects,,,
-emacs, GNU Emacs Manual}): in the simplest case, the ``project'' is
-the single file you are editing, but it can also be all the files in a
-single directory or a directory tree under some version control
-system, such as Git.
+project which use the same programming language. This includes files
+of a given project that are already visited at the time the
+@code{eglot} command is invoked as well as files visited after this
+invocation.
-Alternatively, you can start Eglot automatically from the major-mode
-hook of the mode used for the programming language; see @ref{Starting
-Eglot}.
+The notion of a ``project'' used by Eglot is the same Emacs uses
+(@pxref{Projects,,, emacs, GNU Emacs Manual}): in the simplest case,
+the ``project'' is the single file you are editing, but it can also be
+all the files in a single directory or a directory tree under some
+version control system, such as Git.
+
+There are alternate ways of starting Eglot; see @ref{Starting Eglot}
+for details.
@item
Use Eglot.
@@ -344,6 +347,12 @@ starting an Eglot session is non-interactive, so it should
be used
only when you are confident that Eglot can be started reliably for any
file which may be visited with the major-mode in question.
+Note that it's often difficult to establish this confidence fully, so
+it may be wise to use the interactive command @code{eglot} instead.
+You only need to invoke it once per project, as all other files
+visited within the same project will automatically be managed with no
+further user intervention needed.
+
When Eglot connects to a language server for the first time in an
Emacs session, it runs the hook @code{eglot-connect-hook}
(@pxref{Eglot Variables}).
@@ -1237,8 +1246,8 @@ For example, the plist
@lisp
(:pylsp (:plugins (:jedi_completion (:include_params t
:fuzzy t
- :cache_for ["pandas" "numpy"]
- :pylint (:enabled :json-false))))
+ :cache_for ["pandas" "numpy"])
+ :pylint (:enabled :json-false)))
:gopls (:usePlaceholders t))
@end lisp
@@ -1252,7 +1261,7 @@ is serialized by Eglot to the following JSON text:
"jedi_completion": @{
"include_params": true,
"fuzzy": true,
- "cache_for": [ "pandas", "numpy" ],
+ "cache_for": [ "pandas", "numpy" ]
@},
"pylint": @{
"enabled": false
@@ -1260,8 +1269,8 @@ is serialized by Eglot to the following JSON text:
@}
@},
"gopls": @{
- "usePlaceholders":true
- @},
+ "usePlaceholders": true
+ @}
@}
@end example
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 2f2c166cf8c..801e4b931e2 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -2984,7 +2984,7 @@ connection cleanup or on Emacs exiting.
@cindex rclone setup
The default arguments of the @command{rclone} operations
-@command{mount}, @command{coopyto}, @command{moveto} and
+@command{mount}, @command{copyto}, @command{moveto} and
@command{about} are declared in the variable @code{tramp-methods} as
method specific parameters. Usually, they don't need to be overwritten.
diff --git a/etc/NEWS b/etc/NEWS
index 9c0f28e3fa9..767e4c27b43 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -62,15 +62,17 @@ more details.
** Emacs now supports Unicode Standard version 15.1.
+** Network Security Manager
+
+++
-** The Network Security Manager now warns about 3DES by default.
+*** The Network Security Manager now warns about 3DES by default.
This cypher is no longer recommended owing to a major vulnerability
disclosed in 2016, and its small 112 bit key size. Emacs now warns
about its use also when 'network-security-level' is set to 'medium'
(the default). See 'network-security-protocol-checks'.
---
-** The Network Security Manager now warns about <2048 bits in DH key exchange.
+*** The Network Security Manager now warns about <2048 bits in DH key exchange.
Emacs used to warn for Diffie-Hellman key exchanges with prime numbers
smaller than 1024 bits. Since more servers now support it, this
number has been bumped to 2048 bits.
@@ -149,11 +151,11 @@ When this minor mode is enabled, buttons representing
modifier keys
are displayed along the tool bar.
+++
-** 'd' in the mode line now indicates that the window is dedicated.
+** "d" in the mode line now indicates that the window is dedicated.
Windows have always been able to be dedicated to a specific buffer;
see 'window-dedicated-p'. Now the mode line indicates the dedicated
-status of a window, with 'd' appearing in the mode line if a window is
-dedicated and 'D' if the window is strongly dedicated. This indicator
+status of a window, with "d" appearing in the mode line if a window is
+dedicated and "D" if the window is strongly dedicated. This indicator
appears before the buffer name, and after the buffer modification and
remote buffer indicators (usually "---" together).
@@ -164,11 +166,6 @@ dedicated, so it won't be reused by 'display-buffer'.
This can be
useful for complicated window setups. It is bound to 'C-x w d'
globally.
-** cl-print
-*** You can expand the "..." truncation everywhere.
-The code that allowed "..." to be expanded in the *Backtrace* should
-now work anywhere the data is generated by `cl-print`.
-
---
** New user option 'uniquify-dirname-transform'.
This can be used to customize how buffer names are uniquified, by
@@ -202,12 +199,14 @@ should now work anywhere the data is generated by
'cl-print'.
*** Modes can control the expansion via 'cl-print-expand-ellipsis-function'.
+++
-*** There is a new setting 'raw' for 'cl-print-compiled' which causes
-byte-compiled functions to be printed in full by 'prin1'. A button on
-this output can be activated to disassemble the function.
+*** New setting 'raw' for 'cl-print-compiled'.
+This setting causes byte-compiled functions to be printed in full by
+'prin1'. A button on this output can be activated to disassemble the
+function.
+++
*** There is a new chapter in the CL manual documenting cl-print.el.
+See the Info node "(cl) Printing".
** Modeline elements can now be right-aligned.
Anything following the symbol 'mode-line-format-right-align' in
@@ -222,10 +221,11 @@ It can be used to add, remove and reorder functions that
change
the appearance of every tab on the tab bar.
+++
-** New optional argument for modifying directory local variables
+** New optional argument for modifying directory-local variables.
The commands 'add-dir-local-variable', 'delete-dir-local-variable' and
'copy-file-locals-to-dir-locals' now take an optional prefix argument,
to enter the file you want to modify.
+
** Miscellaneous
---
@@ -336,7 +336,7 @@ functions in CJK locales.
+++
** New command 'lldb'.
Run the LLDB debugger, analogous to the 'gud-gdb' command. Note that
-you might want to add these settings to your .lldbinit file, to reduce
+you might want to add these settings to your ".lldbinit" file, to reduce
the output in the LLDB output when stepping through source files.
settings set stop-line-count-before 0
@@ -396,7 +396,7 @@ switches for shortlogs, such as the one produced by 'C-x v
L'.
*** Obsolete command 'vc-switch-backend' re-added as 'vc-change-backend'.
The command was previously obsoleted and unbound in Emacs 28.
-** Diff Mode
+** Diff mode
+++
*** 'diff-ignore-whitespace-hunk' can now be applied to all hunks.
@@ -563,7 +563,7 @@ The command 'makefile-switch-to-browser' command is now
obsolete,
together with related commands used in the "*Macros and Targets*"
buffer. We recommend using an alternative like 'imenu' instead.
-** Prog Mode
+** Prog mode
+++
*** New command 'prog-fill-reindent-defun'.
@@ -572,10 +572,10 @@ docstring, or a comment, or (re)indents the surrounding
defun if
point is not in a comment or a string. It is by default bound to
'M-q' in 'prog-mode' and all its descendants.
-** Which Function Mode
+** Which Function mode
+++
-*** Which Function Mode can now display function names on the header line.
+*** Which Function mode can now display function names on the header line.
The new user option 'which-func-display' allows choosing where the
function name is displayed. The default is 'mode' to display in the
mode line. 'header' will display in the header line;
@@ -684,13 +684,20 @@ This command adds a docstring comment to the current
defun. If a
comment already exists, point is only moved to the comment. It is
bound to 'C-c C-d' in 'go-ts-mode'.
-** Man-mode
+** Man mode
+++
*** New user option 'Man-prefer-synchronous-call'.
-When this is non-nil, call the 'man' program synchronously rather than
+When this is non-nil, run the 'man' command synchronously rather than
asynchronously (which is the default behavior).
++++
+*** New user option 'Man-support-remote-systems'.
+This option controls whether the man page is formatted on the remote
+system when the current buffer's default-directory is remote. You can
+invoke the 'man' command with a prefix argument to countermand the
+value of this option for the current invocation of 'man'.
+
** DocView
---
@@ -757,7 +764,7 @@ distracting and easily confused with actual code, or a
significant
early aid that relieves you from moving the buffer or reaching for the
mouse to consult an error message.
-** Python Mode
+** Python mode
---
*** New user option 'python-indent-block-paren-deeper'.
@@ -790,7 +797,7 @@ This keyword enables the user to install packages using
'package-vc'.
*** The 'nnweb-type' option 'gmane' has been removed.
The gmane.org website is, sadly, down since a number of years with no
prospect of it coming back. Therefore, it is no longer valid to set
-the user option 'nnweb-type' to the 'gmane'.
+the user option 'nnweb-type' to 'gmane'.
** Rmail
@@ -875,14 +882,13 @@ CPerl mode supports the new keywords for exception
handling and the
object oriented syntax which were added in Perl 5.36 and 5.38.
*** New user option 'cperl-fontify-trailer'.
-This user option takes the values "perl-code" or "comment" and treats
+This user option takes the values 'perl-code' or 'comment' and treats
text after an "__END__" or "__DATA__" token accordingly. The default
-value of "perl-code" is useful for trailing POD and for AutoSplit
-modules, the value "comment" makes cperl-mode treat trailers as
-comment, like perl-mode does.
+value of 'perl-code' is useful for trailing POD and for AutoSplit
+modules, the value 'comment' makes CPerl mode treat trailers as
+comment, like Perl mode does.
*** Commands using the Perl info page are obsolete.
-
The Perl documentation in info format is no longer distributed with
Perl or on CPAN since more than 10 years. Perl documentation can be
read with 'cperl-perldoc' instead.
@@ -942,11 +948,11 @@ neither of which have been supported by Emacs since
version 23.1.
The user option 'url-gateway-nslookup-program' and the function
'url-gateway-nslookup-host' are consequently also obsolete.
-** socks
+** Socks
+++
-*** SOCKS supports version 4a.
-The 'socks-server' option accepts '4a' as a value for its version
+*** Socks supports version 4a.
+The 'socks-server' user option accepts '4a' as a value for its version
field.
** Edmacro
@@ -973,9 +979,10 @@ previously assumed that they should be prefixed with
"http://";. Such
URIs are now prefixed with "https://"; instead.
** Customize
+
+++
-*** New command customize-dirlocals
-This command pops up a buffer to edit the settings in .dir-locals.el
+*** New command 'customize-dirlocals'.
+This command pops up a buffer to edit the settings in ".dir-locals.el".
* New Modes and Packages in Emacs 30.1
@@ -999,8 +1006,23 @@ A major mode based on the tree-sitter library for editing
Elixir files.
*** New major mode 'lua-ts-mode'.
A major mode based on the tree-sitter library for editing Lua files.
+** Minibuffer and Completions
+
+*** New commands 'previous-line-completion' and 'next-line-completion'.
+Bound to '<UP>' and '<DOWN>' arrow keys, respectively, they navigate
+the "*Completions*" buffer vertically by lines, wrapping at the
+top/bottom when 'completion-auto-wrap' is non-nil.
+
+*** New user option 'minibuffer-visible-completions'.
+When customized to non-nil, you can use arrow key in the minibuffer
+to navigate the completions displayed in the *Completions* window.
+Typing 'RET' selects the highlighted candidate. 'C-g' hides the
+completions window. When the completions window is not visible,
+then all these keys have their usual meaning in the minibuffer.
+This option is supported for in-buffer completion as well.
+
+++
-** New global minor mode 'minibuffer-regexp-mode'.
+*** New global minor mode 'minibuffer-regexp-mode'.
This is a minor mode for editing regular expressions in the minibuffer.
It highlights parens via ‘show-paren-mode’ and ‘blink-matching-paren’ in
a user-friendly way, avoids reporting alleged paren mismatches and makes
@@ -1042,11 +1064,28 @@ additionally traverse the parent directories until a
VCS root is found
(if any), so that the ignore rules for that repository are used, and
the file listing's performance is still optimized.
+*** New commands 'project-any-command' and 'project-prefix-or-any-command'.
+The former is now bound to 'C-x p o' by default.
+The latter is designed primarily for use as a value of
+'project-switch-commands'. If instead of a short menu you prefer to
+have access to all keys defined inside 'project-prefix-map', as well
+as global bindings (to run other commands inside the project root),
+you can add this to your init script:
+
+ (setq project-switch-commands #'project-prefix-or-any-command)
+
+** JS Mode
+The binding 'M-.' has been removed from the major mode keymaps in
+'js-mode' and 'js-ts-mode', having it default to the global binding
+which calls 'xref-find-definitions'. If the previous one worked
+better for you, use 'define-key' in your init script to bind
+'js-find-symbol' to that combination again.
+
* Incompatible Lisp Changes in Emacs 30.1
-** `buffer-match-p and `match-buffers` take `&rest args`
-They used to take a single `&optional arg` and were documented to use
+** 'buffer-match-p' and 'match-buffers' take '&rest args'.
+They used to take a single '&optional arg' and were documented to use
an unreliable hack to try and support condition predicates that
don't accept this optional arg.
The new semantics makes no such accommodation, but the code still
@@ -1130,7 +1169,7 @@ The compatibility aliases 'x-defined-colors',
'x-color-defined-p',
Use 'define-minor-mode' and 'define-globalized-minor-mode' instead.
** The obsolete calling convention of 'sit-for' has been removed.
-That convention was: (sit-for SECONDS MILLISEC &optional NODISP)
+That convention was: '(sit-for SECONDS MILLISEC &optional NODISP)'.
** The 'millisec' argument of 'sleep-for' has been declared obsolete.
Use a float value for the first argument instead.
@@ -1147,7 +1186,7 @@ values.
It is now possible for drag-and-drop handler functions to respond to
drops incorporating more than one URL. Functions capable of this must
set their 'dnd-multiple-handler' symbol properties to a non-nil value.
-See the Info node "(elisp)Drag and Drop".
+See the Info node "(elisp) Drag and Drop".
Incident to this change, the function 'dnd-handle-one-url' has been
made obsolete, for it cannot take these new handlers into account.
@@ -1165,8 +1204,8 @@ Other features in Emacs which employ XLFDs have been
modified to
produce and understand XLFDs larger than 255 characters.
** 'defadvice' is marked as obsolete.
-See the "(elisp) Porting Old Advice" node for help converting them
-to use 'advice-add' or 'define-advice' instead.
+See the "(elisp) Porting Old Advice" Info node for help converting
+them to use 'advice-add' or 'define-advice' instead.
** 'cl-old-struct-compat-mode' is marked as obsolete.
You may need to recompile our code if it was compiled with Emacs < 24.3.
@@ -1240,6 +1279,14 @@ with Emacs.
If non-nil, this variable contains a keymap of menu items that are
displayed along tool bar items inside 'tool-bar-map'.
+** New variable 'completion-lazy-hilit'.
+Lisp programs that present completion candidates may bind this
+variable non-nil around calls to functions such as
+'completion-all-completions'. This tells the underlying completion
+styles to skip eager fontification of completion candidates, which
+improves performance. Such a Lisp program can then use the
+'completion-lazy-hilit' function to fontify candidates just in time.
+
** Functions and variables to transpose sexps
+++
@@ -1469,10 +1516,11 @@ When supplied with ':default-language LANGUAGE', rules
after it will
default to use 'LANGUAGE'.
---
-** New optional argument to 'modify-dir-local-variable'
+** New optional argument to 'modify-dir-local-variable'.
A 5th argument, optional, has been added to
'modify-dir-local-variable'. It can be used to specify which
dir-locals file to modify.
+
* Changes in Emacs 30.1 on Non-Free Operating Systems
diff --git a/java/org/gnu/emacs/EmacsNative.java
b/java/org/gnu/emacs/EmacsNative.java
index f15927bb3a7..78176dd0e47 100644
--- a/java/org/gnu/emacs/EmacsNative.java
+++ b/java/org/gnu/emacs/EmacsNative.java
@@ -92,6 +92,13 @@ public final class EmacsNative
loadup.el itself. */
public static native void initEmacs (String argv[], String dumpFile);
+ /* Call shut_down_emacs to auto-save and unlock files in the main
+ thread, then return. */
+ public static native void shutDownEmacs ();
+
+ /* Garbage collect and clear each frame's image cache. */
+ public static native void onLowMemory ();
+
/* Abort and generate a native core dump. */
public static native void emacsAbort ();
diff --git a/java/org/gnu/emacs/EmacsService.java
b/java/org/gnu/emacs/EmacsService.java
index 1325cd85e9b..1aac1a6c4dd 100644
--- a/java/org/gnu/emacs/EmacsService.java
+++ b/java/org/gnu/emacs/EmacsService.java
@@ -321,6 +321,30 @@ public final class EmacsService extends Service
}
}
+ /* The native functions the subsequent two functions call do nothing
+ in the infrequent case the Emacs thread is awaiting a response
+ for the main thread. Caveat emptor! */
+
+ @Override
+ public void
+ onDestroy ()
+ {
+ /* This function is called immediately before the system kills
+ Emacs. In this respect, it is rather akin to a SIGDANGER
+ signal, so force an auto-save accordingly. */
+
+ EmacsNative.shutDownEmacs ();
+ super.onDestroy ();
+ }
+
+ @Override
+ public void
+ onLowMemory ()
+ {
+ EmacsNative.onLowMemory ();
+ super.onLowMemory ();
+ }
+
/* Functions from here on must only be called from the Emacs
diff --git a/lisp/Makefile.in b/lisp/Makefile.in
index c4dd1e7a1f3..0059305cc80 100644
--- a/lisp/Makefile.in
+++ b/lisp/Makefile.in
@@ -95,6 +95,8 @@ COMPILE_FIRST = \
ifeq ($(HAVE_NATIVE_COMP),yes)
COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc
COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp-common.elc
+COMPILE_FIRST += $(lisp)/emacs-lisp/comp-run.elc
endif
COMPILE_FIRST += $(lisp)/emacs-lisp/loaddefs-gen.elc
COMPILE_FIRST += $(lisp)/emacs-lisp/radix-tree.elc
diff --git a/lisp/bookmark.el b/lisp/bookmark.el
index 10ff2f5ebbf..71d76cb4291 100644
--- a/lisp/bookmark.el
+++ b/lisp/bookmark.el
@@ -511,6 +511,8 @@ BM is a bookmark as returned from function
`bookmark-get-bookmark'.
See user option `bookmark-fringe-mark'."
(let ((filename (cdr (assq 'filename bm)))
(pos (cdr (assq 'position bm)))
+ ;; Don't expand file names for non-existing remote connections.
+ (non-essential t)
overlays found temp)
(when (and pos filename)
(setq filename (expand-file-name filename))
diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el
index 652cb8c1a88..b347cc1da23 100644
--- a/lisp/calc/calc.el
+++ b/lisp/calc/calc.el
@@ -906,6 +906,8 @@ Used by `calc-user-invocation'.")
(defvar calc-embedded-mode-hook nil
"Hook run when starting embedded mode.")
+(defvar calc-eval-error)
+
;; The following modes use specially-formatted data.
(put 'calc-mode 'mode-class 'special)
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el
index 2ff620065a5..e0bcae6b005 100644
--- a/lisp/dired-aux.el
+++ b/lisp/dired-aux.el
@@ -1176,7 +1176,7 @@ Return the result of `process-file' - zero for success."
"unxz")
;; zstandard archives
- `(,(rx (or ".tar.zst" ".tzst") eos) "unzstd -c %i | tar -xf -")
+ `(,(rx (or ".tar.zst" ".tzst") eos) "unzstd -c ? | tar -xf -")
`(,(rx ".zst" eos) "unzstd --rm")
'("\\.shar\\.Z\\'" "zcat * | unshar")
diff --git a/lisp/dired.el b/lisp/dired.el
index 231d305210b..c710e06722f 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -4877,22 +4877,30 @@ Ask means pop up a menu for the user to select one of
copy, move or link."
(eval-when-compile (require 'desktop))
(declare-function desktop-file-name "desktop" (filename dirname))
+(defun dired-desktop-save-p ()
+ "Should `dired-directory' be desktop saved?"
+ (if (consp dired-directory)
+ (not (string-match-p desktop-files-not-to-save (car dired-directory)))
+ (not (string-match-p desktop-files-not-to-save dired-directory))))
+
(defun dired-desktop-buffer-misc-data (dirname)
"Auxiliary information to be saved in desktop file."
- (cons
- ;; Value of `dired-directory'.
- (if (consp dired-directory)
- ;; Directory name followed by list of files.
- (cons (desktop-file-name (car dired-directory) dirname)
- (cdr dired-directory))
- ;; Directory name, optionally with shell wildcard.
- (desktop-file-name dired-directory dirname))
- ;; Subdirectories in `dired-subdir-alist'.
- (cdr
- (nreverse
- (mapcar
- (lambda (f) (desktop-file-name (car f) dirname))
- dired-subdir-alist)))))
+ (when (and (stringp desktop-files-not-to-save)
+ (dired-desktop-save-p))
+ (cons
+ ;; Value of `dired-directory'.
+ (if (consp dired-directory)
+ ;; Directory name followed by list of files.
+ (cons (desktop-file-name (car dired-directory) dirname)
+ (cdr dired-directory))
+ ;; Directory name, optionally with shell wildcard.
+ (desktop-file-name dired-directory dirname))
+ ;; Subdirectories in `dired-subdir-alist'.
+ (cdr
+ (nreverse
+ (mapcar
+ (lambda (f) (desktop-file-name (car f) dirname))
+ dired-subdir-alist))))))
(defun dired-restore-desktop-buffer (_file-name
_buffer-name
@@ -4998,6 +5006,7 @@ Interactively with prefix argument, read FILE-NAME."
;;; Miscellaneous commands
(declare-function Man-getpage-in-background "man" (topic))
+(defvar Man-support-remote-systems) ; from man.el
(defvar manual-program) ; from man.el
(defun dired-do-man ()
@@ -5005,10 +5014,11 @@ Interactively with prefix argument, read FILE-NAME."
(interactive nil dired-mode)
(require 'man)
(let* ((file (dired-get-file-for-visit))
+ (Man-support-remote-systems (file-remote-p file))
(manual-program (string-replace "*" "%s"
(dired-guess-shell-command
"Man command: " (list file)))))
- (Man-getpage-in-background file)))
+ (Man-getpage-in-background (file-local-name file))))
(defun dired-do-info ()
"In Dired, run `info' on this file."
diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el
index 7fbdd963e0e..2a668f6ce0e 100644
--- a/lisp/emacs-lisp/advice.el
+++ b/lisp/emacs-lisp/advice.el
@@ -2042,7 +2042,7 @@ in that CLASS."
function class name)))
(error "ad-remove-advice: `%s' is not advised" function)))
-(declare-function comp-subr-trampoline-install "comp")
+(declare-function comp-subr-trampoline-install "comp-run")
;;;###autoload
(defun ad-add-advice (function advice class position)
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index a89bbc3a748..2ca2d03170a 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -635,13 +635,12 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
(and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t))))
;;;###autoload
-(defun cl-remprop (sym tag)
- "Remove from SYMBOL's plist the property PROPNAME and its value.
-\n(fn SYMBOL PROPNAME)"
- (let ((plist (symbol-plist sym)))
- (if (and plist (eq tag (car plist)))
- (progn (setplist sym (cdr (cdr plist))) t)
- (cl--do-remf plist tag))))
+(defun cl-remprop (symbol propname)
+ "Remove from SYMBOL's plist the property PROPNAME and its value."
+ (let ((plist (symbol-plist symbol)))
+ (if (and plist (eq propname (car plist)))
+ (progn (setplist symbol (cdr (cdr plist))) t)
+ (cl--do-remf plist propname))))
;;; Streams.
@@ -872,7 +871,7 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
"%s")
formats)
(cl-incf col (+ col-space (aref cols i))))
- (let ((format (mapconcat #'identity (nreverse formats) "")))
+ (let ((format (mapconcat #'identity (nreverse formats))))
(insert (apply #'format format
(mapcar (lambda (str) (propertize str 'face 'italic))
header))
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index dec14bd5df6..5346678dab0 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -272,7 +272,7 @@ DEFAULT-BODY, if present, is used as the body of a default
method.
(list
(macroexp-warn-and-return
(format "Non-symbol arguments to cl-defgeneric: %s"
- (mapconcat #'prin1-to-string nonsymargs ""))
+ (mapconcat #'prin1-to-string nonsymargs " "))
nil nil nil nonsymargs)))))
next-head)
(while (progn (setq next-head (car-safe (car options-and-methods)))
diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el
index f4c1ac85b13..779f25df572 100644
--- a/lisp/emacs-lisp/cl-lib.el
+++ b/lisp/emacs-lisp/cl-lib.el
@@ -157,6 +157,7 @@ to an element already in the list stored in PLACE.
`(cl-callf2 cl-adjoin ,x ,place ,@keys)))
(defun cl--set-buffer-substring (start end val)
+ "Delete region from START to END and insert VAL."
(save-excursion (delete-region start end)
(goto-char start)
(insert val)
@@ -194,6 +195,8 @@ to an element already in the list stored in PLACE.
;; the target form to return the values as a list.
(defun cl--defalias (cl-f el-f &optional doc)
+ "Define function CL-F as definition EL-F.
+Like `defalias' but marks the alias itself as inlinable."
(defalias cl-f el-f doc)
(put cl-f 'byte-optimizer 'byte-compile-inline-expand))
@@ -533,7 +536,12 @@ If ALIST is non-nil, the new pairs are prepended to it."
(unless (load "cl-loaddefs" 'noerror 'quiet)
;; When bootstrapping, cl-loaddefs hasn't been built yet!
(require 'cl-macs)
- (require 'cl-seq))
+ (require 'cl-seq)
+ ;; FIXME: Arguably we should also load `cl-extra', except that this
+ ;; currently causes more bootstrap troubles, and `cl-extra' is
+ ;; rarely used, so instead we explicitly (require 'cl-extra) at
+ ;; those rare places where we do need it.
+ )
(defun cl--old-struct-type-of (orig-fun object)
(or (and (vectorp object) (> (length object) 0)
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index a4a241d9c63..e2c13534054 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -101,6 +101,7 @@
(and (> size 0) (1- size))))
(defun cl--simple-exprs-p (xs)
+ "Map `cl--simple-expr-p' to each element of list XS."
(while (and xs (cl--simple-expr-p (car xs)))
(setq xs (cdr xs)))
(not xs))
@@ -116,8 +117,10 @@
(while (and (setq x (cdr x)) (cl--safe-expr-p (car x))))
(null x)))))
-;;; Check if constant (i.e., no side effects or dependencies).
(defun cl--const-expr-p (x)
+ "Check if X is constant (i.e., no side effects or dependencies).
+
+See `macroexp-const-p' for similar functionality without cl-lib dependency."
(cond ((consp x)
(or (eq (car x) 'quote)
(and (memq (car x) '(function cl-function))
@@ -3732,7 +3735,7 @@ macro that returns its `&whole' argument."
;;; Things that are inline.
(cl-proclaim '(inline cl-acons cl-map cl-notany cl-notevery cl-revappend
- cl-nreconc gethash))
+ cl-nreconc))
;;; Things that are side-effect-free.
(mapc (lambda (x) (function-put x 'side-effect-free t))
diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el
new file mode 100644
index 00000000000..6318f2a22e5
--- /dev/null
+++ b/lisp/emacs-lisp/comp-common.el
@@ -0,0 +1,553 @@
+;;; comp-common.el --- common code -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <acorallo@gnu.org>
+;; Keywords: lisp
+;; Package: emacs
+
+;; 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:
+
+;; This file holds common code required by comp.el and comp-run.el.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+
+;; These variables and functions are defined in comp.c
+(defvar comp-native-version-dir)
+(defvar native-comp-eln-load-path)
+
+(defgroup comp-common nil
+ "Emacs Lisp native compiler common code."
+ :group 'lisp)
+
+(defcustom native-comp-verbose 0
+ "Compiler verbosity for native compilation, a number between 0 and 3.
+This is intended for debugging the compiler itself.
+ 0 no logging.
+ 1 final LIMPLE is logged.
+ 2 LAP, final LIMPLE, and some pass info are logged.
+ 3 max verbosity."
+ :type 'natnum
+ :risky t
+ :version "28.1")
+
+(defcustom native-comp-never-optimize-functions
+ '(;; The following two are mandatory for Emacs to be working
+ ;; correctly (see comment in `advice--add-function'). DO NOT
+ ;; REMOVE.
+ macroexpand rename-buffer)
+ "Primitive functions to exclude from trampoline optimization.
+
+Primitive functions included in this list will not be called
+directly by the natively-compiled code, which makes trampolines for
+those primitives unnecessary in case of function redefinition/advice."
+ :type '(repeat symbol)
+ :version "28.1")
+
+(defcustom native-comp-async-env-modifier-form nil
+ "Form evaluated before compilation by each asynchronous compilation
subprocess.
+Used to modify the compiler environment."
+ :type 'sexp
+ :risky t
+ :version "28.1")
+
+(defconst comp-known-type-specifiers
+ `(
+ ;; Functions we can trust not to be redefined, or, if redefined,
+ ;; to expose the same type. The vast majority of these are
+ ;; either pure or primitive; the original list is the union of
+ ;; pure + side-effect-free-fns + side-effect-and-error-free-fns:
+ (% (function ((or number marker) (or number marker)) number))
+ (* (function (&rest (or number marker)) number))
+ (+ (function (&rest (or number marker)) number))
+ (- (function (&rest (or number marker)) number))
+ (/ (function ((or number marker) &rest (or number marker)) number))
+ (/= (function ((or number marker) (or number marker)) boolean))
+ (1+ (function ((or number marker)) number))
+ (1- (function ((or number marker)) number))
+ (< (function ((or number marker) &rest (or number marker)) boolean))
+ (<= (function ((or number marker) &rest (or number marker)) boolean))
+ (= (function ((or number marker) &rest (or number marker)) boolean))
+ (> (function ((or number marker) &rest (or number marker)) boolean))
+ (>= (function ((or number marker) &rest (or number marker)) boolean))
+ (abs (function (number) number))
+ (acos (function (number) float))
+ (append (function (&rest t) t))
+ (aref (function (t fixnum) t))
+ (arrayp (function (t) boolean))
+ (ash (function (integer integer) integer))
+ (asin (function (number) float))
+ (assq (function (t list) list))
+ (atan (function (number &optional number) float))
+ (atom (function (t) boolean))
+ (bignump (function (t) boolean))
+ (bobp (function () boolean))
+ (bolp (function () boolean))
+ (bool-vector-count-consecutive
+ (function (bool-vector boolean integer) fixnum))
+ (bool-vector-count-population (function (bool-vector) fixnum))
+ (bool-vector-not (function (bool-vector &optional bool-vector)
bool-vector))
+ (bool-vector-p (function (t) boolean))
+ (bool-vector-subsetp (function (bool-vector bool-vector) boolean))
+ (boundp (function (symbol) boolean))
+ (buffer-end (function ((or number marker)) integer))
+ (buffer-file-name (function (&optional buffer) (or string null)))
+ (buffer-list (function (&optional frame) list))
+ (buffer-local-variables (function (&optional buffer) list))
+ (buffer-modified-p
+ (function (&optional buffer) (or boolean (member autosaved))))
+ (buffer-size (function (&optional buffer) integer))
+ (buffer-string (function () string))
+ (buffer-substring
+ (function ((or integer marker) (or integer marker)) string))
+ (bufferp (function (t) boolean))
+ (byte-code-function-p (function (t) boolean))
+ (capitalize (function (or integer string) (or integer string)))
+ (car (function (list) t))
+ (car-less-than-car (function (list list) boolean))
+ (car-safe (function (t) t))
+ (case-table-p (function (t) boolean))
+ (cdr (function (list) t))
+ (cdr-safe (function (t) t))
+ (ceiling (function (number &optional number) integer))
+ (char-after (function (&optional (or marker integer)) (or fixnum null)))
+ (char-before (function (&optional (or marker integer)) (or fixnum null)))
+ (char-equal (function (integer integer) boolean))
+ (char-or-string-p (function (t) boolean))
+ (char-to-string (function (fixnum) string))
+ (char-width (function (fixnum) fixnum))
+ (characterp (function (t &optional t) boolean))
+ (charsetp (function (t) boolean))
+ (commandp (function (t &optional t) boolean))
+ (compare-strings
+ (function (string (or integer marker null) (or integer marker null) string
+ (or integer marker null) (or integer marker null)
+ &optional t)
+ (or (member t) fixnum)))
+ (concat (function (&rest sequence) string))
+ (cons (function (t t) cons))
+ (consp (function (t) boolean))
+ (coordinates-in-window-p
+ (function (cons window)
+ (or cons null
+ (member bottom-divider right-divider mode-line header-line
+ tab-line left-fringe right-fringe vertical-line
+ left-margin right-margin))))
+ (copy-alist (function (list) list))
+ (copy-marker (function (&optional (or integer marker) boolean) marker))
+ (copy-sequence (function (sequence) sequence))
+ (copysign (function (float float) float))
+ (cos (function (number) float))
+ (count-lines
+ (function ((or integer marker) (or integer marker) &optional t) integer))
+ (current-buffer (function () buffer))
+ (current-global-map (function () cons))
+ (current-indentation (function () integer))
+ (current-local-map (function () (or cons null)))
+ (current-minor-mode-maps (function () (or cons null)))
+ (current-time (function () cons))
+ (current-time-string (function (&optional (or number list)
+ (or symbol string cons integer))
+ string))
+ (current-time-zone (function (&optional (or number list)
+ (or symbol string cons integer))
+ cons))
+ (custom-variable-p (function (symbol) t))
+ (decode-char (function (cons t) (or fixnum null)))
+ (decode-time (function (&optional (or number list)
+ (or symbol string cons integer)
+ symbol)
+ cons))
+ (default-boundp (function (symbol) boolean))
+ (default-value (function (symbol) t))
+ (degrees-to-radians (function (number) float))
+ (documentation
+ (function ((or function symbol subr) &optional t) (or null string)))
+ (downcase (function ((or fixnum string)) (or fixnum string)))
+ (elt (function (sequence integer) t))
+ (encode-char (function (fixnum symbol) (or fixnum null)))
+ (encode-time (function (cons &rest t) cons))
+ (eobp (function () boolean))
+ (eolp (function () boolean))
+ (eq (function (t t) boolean))
+ (eql (function (t t) boolean))
+ (equal (function (t t) boolean))
+ (error-message-string (function (list) string))
+ (eventp (function (t) boolean))
+ (exp (function (number) float))
+ (expt (function (number number) number))
+ (fboundp (function (symbol) boolean))
+ (fceiling (function (float) float))
+ (featurep (function (symbol &optional symbol) boolean))
+ (ffloor (function (float) float))
+ (file-directory-p (function (string) boolean))
+ (file-exists-p (function (string) boolean))
+ (file-locked-p (function (string) (or boolean string)))
+ (file-name-absolute-p (function (string) boolean))
+ (file-newer-than-file-p (function (string string) boolean))
+ (file-readable-p (function (string) boolean))
+ (file-symlink-p (function (string) (or boolean string)))
+ (file-writable-p (function (string) boolean))
+ (fixnump (function (t) boolean))
+ (float (function (number) float))
+ (float-time (function (&optional (or number list)) float))
+ (floatp (function (t) boolean))
+ (floor (function (number &optional number) integer))
+ (following-char (function () fixnum))
+ (format (function (string &rest t) string))
+ (format-time-string (function (string &optional (or number list)
+ (or symbol string cons integer))
+ string))
+ (frame-first-window (function ((or frame window)) window))
+ (frame-root-window (function (&optional (or frame window)) window))
+ (frame-selected-window (function (&optional (or frame window)) window))
+ (frame-visible-p (function (frame) (or boolean (member icon))))
+ (framep (function (t) symbol))
+ (fround (function (float) float))
+ (ftruncate (function (float) float))
+ (get (function (symbol symbol) t))
+ (get-buffer (function ((or buffer string)) (or buffer null)))
+ (get-buffer-window
+ (function (&optional (or buffer string) (or symbol (integer 0 0)))
+ (or null window)))
+ (get-file-buffer (function (string) (or null buffer)))
+ (get-largest-window (function (&optional t t t) (or window null)))
+ (get-lru-window (function (&optional t t t) (or window null)))
+ (getenv (function (string &optional frame) (or null string)))
+ (gethash (function (t hash-table &optional t) t))
+ (hash-table-count (function (hash-table) integer))
+ (hash-table-p (function (t) boolean))
+ (identity (function (t) t))
+ (ignore (function (&rest t) null))
+ (int-to-string (function (number) string))
+ (integer-or-marker-p (function (t) boolean))
+ (integerp (function (t) boolean))
+ (interactive-p (function () boolean))
+ (intern-soft (function ((or string symbol) &optional vector) symbol))
+ (invocation-directory (function () string))
+ (invocation-name (function () string))
+ (isnan (function (float) boolean))
+ (keymap-parent (function (cons) (or cons null)))
+ (keymapp (function (t) boolean))
+ (keywordp (function (t) boolean))
+ (last (function (list &optional integer) list))
+ (lax-plist-get (function (list t) t))
+ (ldexp (function (number integer) float))
+ (length (function (t) (integer 0 *)))
+ (length< (function (sequence fixnum) boolean))
+ (length= (function (sequence fixnum) boolean))
+ (length> (function (sequence fixnum) boolean))
+ (line-beginning-position (function (&optional integer) integer))
+ (line-end-position (function (&optional integer) integer))
+ (list (function (&rest t) list))
+ (listp (function (t) boolean))
+ (local-variable-if-set-p (function (symbol &optional buffer) boolean))
+ (local-variable-p (function (symbol &optional buffer) boolean))
+ (locale-info (function ((member codeset days months paper)) (or null
string)))
+ (log (function (number number) float))
+ (log10 (function (number) float))
+ (logand (function (&rest (or integer marker)) integer))
+ (logb (function (number) integer))
+ (logcount (function (integer) integer))
+ (logior (function (&rest (or integer marker)) integer))
+ (lognot (function (integer) integer))
+ (logxor (function (&rest (or integer marker)) integer))
+ ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ?
+ (lsh (function (integer integer) integer))
+ (make-byte-code
+ (function ((or fixnum list) string vector integer &optional string t
+ &rest t)
+ vector))
+ (make-list (function (integer t) list))
+ (make-marker (function () marker))
+ (make-string (function (integer fixnum &optional t) string))
+ (make-symbol (function (string) symbol))
+ (mark (function (&optional t) (or integer null)))
+ (mark-marker (function () marker))
+ (marker-buffer (function (marker) (or buffer null)))
+ (markerp (function (t) boolean))
+ (max (function ((or number marker) &rest (or number marker)) number))
+ (max-char (function (&optional t) fixnum))
+ (member (function (t list) list))
+ (memory-limit (function () integer))
+ (memq (function (t list) list))
+ (memql (function (t list) list))
+ (min (function ((or number marker) &rest (or number marker)) number))
+ (minibuffer-selected-window (function () (or window null)))
+ (minibuffer-window (function (&optional frame) window))
+ (mod
+ (function ((or number marker) (or number marker))
+ (or (integer 0 *) (float 0 *))))
+ (mouse-movement-p (function (t) boolean))
+ (multibyte-char-to-unibyte (function (fixnum) fixnum))
+ (natnump (function (t) boolean))
+ (next-window (function (&optional window t t) window))
+ (nlistp (function (t) boolean))
+ (not (function (t) boolean))
+ (nth (function (integer list) t))
+ (nthcdr (function (integer t) t))
+ (null (function (t) boolean))
+ (number-or-marker-p (function (t) boolean))
+ (number-to-string (function (number) string))
+ (numberp (function (t) boolean))
+ (one-window-p (function (&optional t t) boolean))
+ (overlayp (function (t) boolean))
+ (parse-colon-path (function (string) cons))
+ (plist-get (function (list t &optional t) t))
+ (plist-member (function (list t &optional t) list))
+ (point (function () integer))
+ (point-marker (function () marker))
+ (point-max (function () integer))
+ (point-min (function () integer))
+ (preceding-char (function () fixnum))
+ (previous-window (function (&optional window t t) window))
+ (prin1-to-string (function (t &optional t t) string))
+ (processp (function (t) boolean))
+ (proper-list-p (function (t) (or fixnum null)))
+ (propertize (function (string &rest t) string))
+ (radians-to-degrees (function (number) float))
+ (rassoc (function (t list) list))
+ (rassq (function (t list) list))
+ (read-from-string (function (string &optional integer integer) cons))
+ (recent-keys (function (&optional (or cons null)) vector))
+ (recursion-depth (function () integer))
+ (regexp-opt (function (list) string))
+ (regexp-quote (function (string) string))
+ (region-beginning (function () integer))
+ (region-end (function () integer))
+ (reverse (function (sequence) sequence))
+ (round (function (number &optional number) integer))
+ (safe-length (function (t) integer))
+ (selected-frame (function () frame))
+ (selected-window (function () window))
+ (sequencep (function (t) boolean))
+ (sin (function (number) float))
+ (sqrt (function (number) float))
+ (standard-case-table (function () char-table))
+ (standard-syntax-table (function () char-table))
+ (string (function (&rest fixnum) string))
+ (string-as-multibyte (function (string) string))
+ (string-as-unibyte (function (string) string))
+ (string-equal (function ((or string symbol) (or string symbol)) boolean))
+ (string-lessp (function ((or string symbol) (or string symbol)) boolean))
+ (string-make-multibyte (function (string) string))
+ (string-make-unibyte (function (string) string))
+ (string-search (function (string string &optional integer) (or integer
null)))
+ (string-to-char (function (string) fixnum))
+ (string-to-multibyte (function (string) string))
+ (string-to-number (function (string &optional integer) number))
+ (string-to-syntax (function (string) (or cons null)))
+ (string< (function ((or string symbol) (or string symbol)) boolean))
+ (string= (function ((or string symbol) (or string symbol)) boolean))
+ (stringp (function (t) boolean))
+ (subrp (function (t) boolean))
+ (substring
+ (function ((or string vector) &optional integer integer) (or string
vector)))
+ (sxhash (function (t) integer))
+ (sxhash-eq (function (t) integer))
+ (sxhash-eql (function (t) integer))
+ (sxhash-equal (function (t) integer))
+ (symbol-function (function (symbol) t))
+ (symbol-name (function (symbol) string))
+ (symbol-plist (function (symbol) list))
+ (symbol-value (function (symbol) t))
+ (symbolp (function (t) boolean))
+ (syntax-table (function () char-table))
+ (syntax-table-p (function (t) boolean))
+ (tan (function (number) float))
+ (this-command-keys (function () string))
+ (this-command-keys-vector (function () vector))
+ (this-single-command-keys (function () vector))
+ (this-single-command-raw-keys (function () vector))
+ (time-convert (function ((or number list) &optional (or symbol integer))
+ (or cons number)))
+ (truncate (function (number &optional number) integer))
+ (type-of (function (t) symbol))
+ (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum
+ (upcase (function ((or fixnum string)) (or fixnum string)))
+ (user-full-name (function (&optional integer) (or string null)))
+ (user-login-name (function (&optional integer) (or string null)))
+ (user-original-login-name (function (&optional integer) (or string null)))
+ (user-real-login-name (function () string))
+ (user-real-uid (function () integer))
+ (user-uid (function () integer))
+ (vconcat (function (&rest sequence) vector))
+ (vector (function (&rest t) vector))
+ (vectorp (function (t) boolean))
+ (visible-frame-list (function () list))
+ (wholenump (function (t) boolean))
+ (window-configuration-p (function (t) boolean))
+ (window-live-p (function (t) boolean))
+ (window-valid-p (function (t) boolean))
+ (windowp (function (t) boolean))
+ (zerop (function (number) boolean))
+ ;; Type hints
+ (comp-hint-fixnum (function (t) fixnum))
+ (comp-hint-cons (function (t) cons))
+ ;; Non returning functions
+ (throw (function (t t) nil))
+ (error (function (string &rest t) nil))
+ (signal (function (symbol t) nil)))
+ "Alist used for type propagation.")
+
+(defconst comp-limple-calls '(call
+ callref
+ direct-call
+ direct-callref)
+ "Limple operators used to call subrs.")
+
+(defconst comp-limple-sets '(set
+ setimm
+ set-par-to-local
+ set-args-to-local
+ set-rest-args-to-local)
+ "Limple set operators.")
+
+(defconst comp-limple-assignments `(assume
+ fetch-handler
+ ,@comp-limple-sets)
+ "Limple operators that clobber the first m-var argument.")
+
+(defconst comp-limple-branches '(jump cond-jump)
+ "Limple operators used for conditional and unconditional branches.")
+
+(defconst comp-limple-ops `(,@comp-limple-calls
+ ,@comp-limple-assignments
+ ,@comp-limple-branches
+ return)
+ "All Limple operators.")
+
+(defconst comp-limple-lock-keywords
+ `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face)
+ (,(rx "#(" (group-n 1 "mvar"))
+ (1 font-lock-function-name-face))
+ (,(rx bol "(" (group-n 1 "phi"))
+ (1 font-lock-variable-name-face))
+ (,(rx bol "(" (group-n 1 (or "return" "unreachable")))
+ (1 font-lock-warning-face))
+ (,(rx (group-n 1 (or "entry"
+ (seq (or "entry_" "entry_fallback_" "bb_")
+ (1+ num) (? (or "_latch"
+ (seq "_cstrs_" (1+ num))))))))
+ (1 font-lock-constant-face))
+ (,(rx-to-string
+ `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops)))))
+ (1 font-lock-keyword-face)))
+ "Highlights used by `native-comp-limple-mode'.")
+
+(defconst comp-log-buffer-name "*Native-compile-Log*"
+ "Name of the native-compiler log buffer.")
+
+(cl-defun comp-log (data &optional (level 1) quoted)
+ "Log DATA at LEVEL.
+LEVEL is a number from 1-3, and defaults to 1; if it is less
+than `native-comp-verbose', do nothing. If `noninteractive', log
+with `message'. Otherwise, log with `comp-log-to-buffer'."
+ (when (>= native-comp-verbose level)
+ (if noninteractive
+ (cl-typecase data
+ (atom (message "%s" data))
+ (t (dolist (elem data)
+ (message "%s" elem))))
+ (comp-log-to-buffer data quoted))))
+
+(define-derived-mode native-comp-limple-mode fundamental-mode "LIMPLE"
+ "Syntax-highlight LIMPLE IR."
+ (setf font-lock-defaults '(comp-limple-lock-keywords)))
+
+(cl-defun comp-log-to-buffer (data &optional quoted)
+ "Log DATA to `comp-log-buffer-name'."
+ (let* ((print-f (if quoted #'prin1 #'princ))
+ (log-buffer
+ (or (get-buffer comp-log-buffer-name)
+ (with-current-buffer (get-buffer-create comp-log-buffer-name)
+ (unless (derived-mode-p 'compilation-mode)
+ (emacs-lisp-compilation-mode))
+ (current-buffer))))
+ (log-window (get-buffer-window log-buffer))
+ (inhibit-read-only t)
+ at-end-p)
+ (with-current-buffer log-buffer
+ (unless (eq major-mode 'native-comp-limple-mode)
+ (native-comp-limple-mode))
+ (when (= (point) (point-max))
+ (setf at-end-p t))
+ (save-excursion
+ (goto-char (point-max))
+ (cl-typecase data
+ (atom (funcall print-f data log-buffer))
+ (t (dolist (elem data)
+ (funcall print-f elem log-buffer)
+ (insert "\n"))))
+ (insert "\n"))
+ (when (and at-end-p log-window)
+ ;; When log window's point is at the end, follow the tail.
+ (with-selected-window log-window
+ (goto-char (point-max)))))))
+
+(defun comp-ensure-native-compiler ()
+ "Make sure Emacs has native compiler support and libgccjit can be loaded.
+Signal an error otherwise.
+To be used by all entry points."
+ (cond
+ ((null (featurep 'native-compile))
+ (error "Emacs was not compiled with native compiler support
(--with-native-compilation)"))
+ ((null (native-comp-available-p))
+ (error "Cannot find libgccjit library"))))
+
+(defun comp-trampoline-filename (subr-name)
+ "Given SUBR-NAME return the filename containing the trampoline."
+ (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
+
+(defun comp-eln-load-path-eff ()
+ "Return a list of effective eln load directories.
+Account for `native-comp-eln-load-path' and `comp-native-version-dir'."
+ (mapcar (lambda (dir)
+ (expand-file-name comp-native-version-dir
+ (file-name-as-directory
+ (expand-file-name dir invocation-directory))))
+ native-comp-eln-load-path))
+
+;;;###autoload
+(defun comp-function-type-spec (function)
+ "Return the type specifier of FUNCTION.
+
+This function returns a cons cell whose car is the function
+specifier, and cdr is a symbol, either `inferred' or `know'.
+If the symbol is `inferred', the type specifier is automatically
+inferred from the code itself by the native compiler; if it is
+`know', the type specifier comes from `comp-known-type-specifiers'."
+ (let ((kind 'know)
+ type-spec )
+ (when-let ((res (assoc function comp-known-type-specifiers)))
+ (setf type-spec (cadr res)))
+ (let ((f (and (symbolp function)
+ (symbol-function function))))
+ (when (and f
+ (null type-spec)
+ (subr-native-elisp-p f))
+ (setf kind 'inferred
+ type-spec (subr-type f))))
+ (when type-spec
+ (cons type-spec kind))))
+
+(provide 'comp-common)
+
+;;; comp-common.el ends here
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index ee0ae10539d..e47e93cda18 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -36,7 +36,7 @@
;;; Code:
(require 'cl-lib)
-(require 'cl-macs)
+(require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing.
(defconst comp--typeof-builtin-types (mapcar (lambda (x)
(append x '(t)))
@@ -269,16 +269,6 @@ Return them as multiple value."
(string-lessp (symbol-name x)
(symbol-name y)))
-(defun comp--direct-supertype (type) ;FIXME: There can be several!
- "Return the direct supertype of TYPE."
- (declare (obsolete comp--direct-supertype "30.1"))
- (cl-loop
- named outer
- for i in (comp-cstr-ctxt-typeof-types comp-ctxt)
- do (cl-loop for (j y) on i
- when (eq j type)
- do (cl-return-from outer y))))
-
(defun comp--direct-supertypes (type)
"Return the direct supertypes of TYPE."
(let ((supers (comp-supertypes type)))
@@ -293,6 +283,14 @@ Return them as multiple value."
(setq notdirect (append notdirect (comp-supertypes parent))))
finally return direct)))
+(defsubst comp-subtype-p (type1 type2)
+ "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise."
+ (let ((types (cons type1 type2)))
+ (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt))
+ (puthash types
+ (memq type2 (comp-supertypes type1))
+ (comp-cstr-ctxt-subtype-p-mem comp-ctxt)))))
+
(defun comp--normalize-typeset0 (typeset)
;; For every type search its supertypes. If all the subtypes of a
;; supertype are presents remove all of them, add the identified
@@ -373,14 +371,6 @@ Return them as multiple value."
(if above (comp--intersection x above) x)))))
finally return above))
-(defsubst comp-subtype-p (type1 type2)
- "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise."
- (let ((types (cons type1 type2)))
- (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt))
- (puthash types
- (memq type2 (comp-supertypes type1))
- (comp-cstr-ctxt-subtype-p-mem comp-ctxt)))))
-
(defun comp-union-typesets (&rest typesets)
"Union types present into TYPESETS."
(or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt))
diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el
new file mode 100644
index 00000000000..5335003e25b
--- /dev/null
+++ b/lisp/emacs-lisp/comp-run.el
@@ -0,0 +1,459 @@
+;;; comp-runtime.el --- runtime Lisp native compiler code -*-
lexical-binding: t -*-
+
+;; Copyright (C) 2023 Free Software Foundation, Inc.
+
+;; Author: Andrea Corallo <acorallo@gnu.org>
+;; Keywords: lisp
+;; Package: emacs
+
+;; 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:
+
+;; While the main native compiler is implemented in comp.el, when
+;; commonly used as a jit compiler it is only loaded by Emacs sub
+;; processes performing async compilation. This files contains all
+;; the code needed to drive async compilations and any Lisp code
+;; needed at runtime to run native code.
+
+;;; Code:
+
+(eval-when-compile (require 'cl-lib))
+(require 'comp-common)
+
+(defgroup comp-run nil
+ "Emacs Lisp native compiler runtime."
+ :group 'lisp)
+
+(defcustom native-comp-jit-compilation-deny-list
+ '()
+ "List of regexps to exclude matching files from deferred native compilation.
+Files whose names match any regexp are excluded from native compilation."
+ :type '(repeat regexp)
+ :version "28.1")
+
+(defcustom native-comp-async-jobs-number 0
+ "Default number of subprocesses used for async native compilation.
+Value of zero means to use half the number of the CPU's execution units,
+or one if there's just one execution unit."
+ :type 'natnum
+ :risky t
+ :version "28.1")
+
+(defcustom native-comp-async-report-warnings-errors t
+ "Whether to report warnings and errors from asynchronous native compilation.
+
+When native compilation happens asynchronously, it can produce
+warnings and errors, some of which might not be emitted by a
+byte-compilation. The typical case for that is native-compiling
+a file that is missing some `require' of a necessary feature,
+while having it already loaded into the environment when
+byte-compiling.
+
+As asynchronous native compilation always starts from a pristine
+environment, it is more sensitive to such omissions, and might be
+unable to compile such Lisp source files correctly.
+
+Set this variable to nil to suppress warnings altogether, or to
+the symbol `silent' to log warnings but not pop up the *Warnings*
+buffer."
+ :type '(choice
+ (const :tag "Do not report warnings" nil)
+ (const :tag "Report and display warnings" t)
+ (const :tag "Report but do not display warnings" silent))
+ :version "28.1")
+
+(defcustom native-comp-always-compile nil
+ "Non-nil means unconditionally (re-)compile all files."
+ :type 'boolean
+ :version "28.1")
+
+(make-obsolete-variable 'native-comp-deferred-compilation-deny-list
+ 'native-comp-jit-compilation-deny-list
+ "29.1")
+
+(defcustom native-comp-async-cu-done-functions nil
+ "List of functions to call when asynchronous compilation of a file is done.
+Each function is called with one argument FILE, the filename whose
+compilation has completed."
+ :type 'hook
+ :version "28.1")
+
+(defcustom native-comp-async-all-done-hook nil
+ "Hook run after completing asynchronous compilation of all input files."
+ :type 'hook
+ :version "28.1")
+
+(defcustom native-comp-async-query-on-exit nil
+ "Whether to query the user about killing async compilations when exiting.
+If this is non-nil, Emacs will ask for confirmation to exit and kill the
+asynchronous native compilations if any are running. If nil, when you
+exit Emacs, it will silently kill those asynchronous compilations even
+if `confirm-kill-processes' is non-nil."
+ :type 'boolean
+ :version "28.1")
+
+(defconst comp-async-buffer-name "*Async-native-compile-log*"
+ "Name of the async compilation buffer log.")
+
+(defvar comp-no-spawn nil
+ "Non-nil don't spawn native compilation processes.")
+
+(defvar comp-async-compilations (make-hash-table :test #'equal)
+ "Hash table file-name -> async compilation process.")
+
+;; These variables and functions are defined in comp.c
+(defvar comp--no-native-compile)
+(defvar comp-deferred-pending-h)
+(defvar comp-installed-trampolines-h)
+(defvar native-comp-enable-subr-trampolines)
+
+(declare-function comp--install-trampoline "comp.c")
+(declare-function comp-el-to-eln-filename "comp.c")
+(declare-function native-elisp-load "comp.c")
+
+(defun native-compile-async-skip-p (file load selector)
+ "Return non-nil if FILE's compilation should be skipped.
+
+LOAD and SELECTOR work as described in `native--compile-async'."
+ ;; Make sure we are not already compiling `file' (bug#40838).
+ (or (gethash file comp-async-compilations)
+ (gethash (file-name-with-extension file "elc") comp--no-native-compile)
+ (cond
+ ((null selector) nil)
+ ((functionp selector) (not (funcall selector file)))
+ ((stringp selector) (not (string-match-p selector file)))
+ (t (error "SELECTOR must be a function a regexp or nil")))
+ ;; Also exclude files from deferred compilation if
+ ;; any of the regexps in
+ ;; `native-comp-jit-compilation-deny-list' matches.
+ (and (eq load 'late)
+ (seq-some (lambda (re)
+ (string-match-p re file))
+ native-comp-jit-compilation-deny-list))))
+
+(defvar comp-files-queue ()
+ "List of Emacs Lisp files to be compiled.")
+
+(defvar comp-async-compilations (make-hash-table :test #'equal)
+ "Hash table file-name -> async compilation process.")
+
+(defun comp-async-runnings ()
+ "Return the number of async compilations currently running.
+This function has the side effect of cleaning-up finished
+processes from `comp-async-compilations'"
+ (cl-loop
+ for file-name in (cl-loop
+ for file-name being each hash-key of
comp-async-compilations
+ for prc = (gethash file-name comp-async-compilations)
+ unless (process-live-p prc)
+ collect file-name)
+ do (remhash file-name comp-async-compilations))
+ (hash-table-count comp-async-compilations))
+
+(defvar comp-num-cpus nil)
+(defun comp-effective-async-max-jobs ()
+ "Compute the effective number of async jobs."
+ (if (zerop native-comp-async-jobs-number)
+ (or comp-num-cpus
+ (setf comp-num-cpus
+ (max 1 (/ (num-processors) 2))))
+ native-comp-async-jobs-number))
+
+(defvar comp-last-scanned-async-output nil)
+(make-variable-buffer-local 'comp-last-scanned-async-output)
+;; From warnings.el
+(defvar warning-suppress-types)
+(defun comp-accept-and-process-async-output (process)
+ "Accept PROCESS output and check for diagnostic messages."
+ (if native-comp-async-report-warnings-errors
+ (let ((warning-suppress-types
+ (if (eq native-comp-async-report-warnings-errors 'silent)
+ (cons '(comp) warning-suppress-types)
+ warning-suppress-types)))
+ (with-current-buffer (process-buffer process)
+ (save-excursion
+ (accept-process-output process)
+ (goto-char (or comp-last-scanned-async-output (point-min)))
+ (while (re-search-forward "^.*?\\(?:Error\\|Warning\\): .*$"
+ nil t)
+ (display-warning 'comp (match-string 0)))
+ (setq comp-last-scanned-async-output (point-max)))))
+ (accept-process-output process)))
+
+(defconst comp-valid-source-re (rx ".el" (? ".gz") eos)
+ "Regexp to match filename of valid input source files.")
+
+(defun comp-run-async-workers ()
+ "Start compiling files from `comp-files-queue' asynchronously.
+When compilation is finished, run `native-comp-async-all-done-hook' and
+display a message."
+ (cl-assert (null comp-no-spawn))
+ (if (or comp-files-queue
+ (> (comp-async-runnings) 0))
+ (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ (cl-loop
+ for (source-file . load) = (pop comp-files-queue)
+ while source-file
+ do (cl-assert (string-match-p comp-valid-source-re source-file) nil
+ "`comp-files-queue' should be \".el\" files: %s"
+ source-file)
+ when (or native-comp-always-compile
+ load ; Always compile when the compilation is
+ ; commanded for late load.
+ ;; Skip compilation if `comp-el-to-eln-filename' fails
+ ;; to find a writable directory.
+ (with-demoted-errors "Async compilation :%S"
+ (file-newer-than-file-p
+ source-file (comp-el-to-eln-filename source-file))))
+ do (let* ((expr `((require 'comp)
+ (setq comp-async-compilation t
+ warning-fill-column most-positive-fixnum)
+ ,(let ((set (list 'setq)))
+ (dolist (var '(comp-file-preloaded-p
+ native-compile-target-directory
+ native-comp-speed
+ native-comp-debug
+ native-comp-verbose
+ comp-libgccjit-reproducer
+ native-comp-eln-load-path
+ native-comp-compiler-options
+ native-comp-driver-options
+ load-path
+ backtrace-line-length
+ byte-compile-warnings
+ ;; package-load-list
+ ;; package-user-dir
+ ;; package-directory-list
+ ))
+ (when (boundp var)
+ (push var set)
+ (push `',(symbol-value var) set)))
+ (nreverse set))
+ ;; FIXME: Activating all packages would align the
+ ;; functionality offered with what is usually done
+ ;; for ELPA packages (and thus fix some compilation
+ ;; issues with some ELPA packages), but it's too
+ ;; blunt an instrument (e.g. we don't even know if
+ ;; we're compiling such an ELPA package at
+ ;; this point).
+ ;;(package-activate-all)
+ ,native-comp-async-env-modifier-form
+ (message "Compiling %s..." ,source-file)
+ (comp--native-compile ,source-file ,(and load t))))
+ (source-file1 source-file) ;; Make the closure works :/
+ (temp-file (make-temp-file
+ (concat "emacs-async-comp-"
+ (file-name-base source-file) "-")
+ nil ".el"))
+ (expr-strings (let ((print-length nil)
+ (print-level nil))
+ (mapcar #'prin1-to-string expr)))
+ (_ (progn
+ (with-temp-file temp-file
+ (mapc #'insert expr-strings))
+ (comp-log "\n")
+ (mapc #'comp-log expr-strings)))
+ (load1 load)
+ (default-directory invocation-directory)
+ (process (make-process
+ :name (concat "Compiling: " source-file)
+ :buffer (with-current-buffer
+ (get-buffer-create
+ comp-async-buffer-name)
+ (unless (derived-mode-p
'compilation-mode)
+ (emacs-lisp-compilation-mode))
+ (current-buffer))
+ :command (list
+ (expand-file-name invocation-name
+ invocation-directory)
+ "-no-comp-spawn" "-Q" "--batch"
+ "--eval"
+ ;; Suppress Abort dialogs on MS-Windows
+ "(setq w32-disable-abort-dialog t)"
+ "-l" temp-file)
+ :sentinel
+ (lambda (process _event)
+ (run-hook-with-args
+ 'native-comp-async-cu-done-functions
+ source-file)
+ (comp-accept-and-process-async-output process)
+ (ignore-errors (delete-file temp-file))
+ (let ((eln-file (comp-el-to-eln-filename
+ source-file1)))
+ (when (and load1
+ (zerop (process-exit-status
+ process))
+ (file-exists-p eln-file))
+ (native-elisp-load eln-file
+ (eq load1 'late))))
+ (comp-run-async-workers))
+ :noquery (not native-comp-async-query-on-exit))))
+ (puthash source-file process comp-async-compilations))
+ when (>= (comp-async-runnings) (comp-effective-async-max-jobs))
+ do (cl-return)))
+ ;; No files left to compile and all processes finished.
+ (run-hooks 'native-comp-async-all-done-hook)
+ (with-current-buffer (get-buffer-create comp-async-buffer-name)
+ (save-excursion
+ (unless (derived-mode-p 'compilation-mode)
+ (emacs-lisp-compilation-mode))
+ (let ((inhibit-read-only t))
+ (goto-char (point-max))
+ (insert "Compilation finished.\n"))))
+ ;; `comp-deferred-pending-h' should be empty at this stage.
+ ;; Reset it anyway.
+ (clrhash comp-deferred-pending-h)))
+
+(defconst comp-warn-primitives
+ '(null memq gethash and subrp not subr-native-elisp-p
+ comp--install-trampoline concat if symbolp symbol-name make-string
+ length aset aref length> mapcar expand-file-name
+ file-name-as-directory file-exists-p native-elisp-load)
+ "List of primitives we want to warn about in case of redefinition.
+This are essential for the trampoline machinery to work properly.")
+
+(defun comp-trampoline-search (subr-name)
+ "Search a trampoline file for SUBR-NAME.
+Return the trampoline if found or nil otherwise."
+ (cl-loop
+ with rel-filename = (comp-trampoline-filename subr-name)
+ for dir in (comp-eln-load-path-eff)
+ for filename = (expand-file-name rel-filename dir)
+ when (file-exists-p filename)
+ do (cl-return (native-elisp-load filename))))
+
+(declare-function comp-trampoline-compile "comp")
+;;;###autoload
+(defun comp-subr-trampoline-install (subr-name)
+ "Make SUBR-NAME effectively advice-able when called from native code."
+ (when (memq subr-name comp-warn-primitives)
+ (warn "Redefining `%s' might break native compilation of trampolines."
+ subr-name))
+ (unless (or (null native-comp-enable-subr-trampolines)
+ (memq subr-name native-comp-never-optimize-functions)
+ (gethash subr-name comp-installed-trampolines-h))
+ (cl-assert (subr-primitive-p (symbol-function subr-name)))
+ (when-let ((trampoline (or (comp-trampoline-search subr-name)
+ (comp-trampoline-compile subr-name))))
+ (comp--install-trampoline subr-name trampoline))))
+
+;;;###autoload
+(defun native--compile-async (files &optional recursively load selector)
+ ;; BEWARE, this function is also called directly from C.
+ "Compile FILES asynchronously.
+FILES is one filename or a list of filenames or directories.
+
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
+
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
+
+The optional argument SELECTOR has the following valid values:
+
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `native-comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously.
+
+LOAD can also be the symbol `late'. This is used internally if
+the byte code has already been loaded when this function is
+called. It means that we request the special kind of load
+necessary in that situation, called \"late\" loading.
+
+During a \"late\" load, instead of executing all top-level forms
+of the original files, only function definitions are
+loaded (paying attention to have these effective only if the
+bytecode definition was not changed in the meantime)."
+ (comp-ensure-native-compiler)
+ (unless (member load '(nil t late))
+ (error "LOAD must be nil, t or 'late"))
+ (unless (listp files)
+ (setf files (list files)))
+ (let ((added-something nil)
+ file-list)
+ (dolist (file-or-dir files)
+ (cond ((file-directory-p file-or-dir)
+ (dolist (file (if recursively
+ (directory-files-recursively
+ file-or-dir comp-valid-source-re)
+ (directory-files file-or-dir
+ t comp-valid-source-re)))
+ (push file file-list)))
+ ((file-exists-p file-or-dir) (push file-or-dir file-list))
+ (t (signal 'native-compiler-error
+ (list "Not a file nor directory" file-or-dir)))))
+ (dolist (file file-list)
+ (if-let ((entry (seq-find (lambda (x) (string= file (car x)))
comp-files-queue)))
+ ;; Most likely the byte-compiler has requested a deferred
+ ;; compilation, so update `comp-files-queue' to reflect that.
+ (unless (or (null load)
+ (eq load (cdr entry)))
+ (setf comp-files-queue
+ (cl-loop for i in comp-files-queue
+ with old = (car entry)
+ if (string= (car i) old)
+ collect (cons file load)
+ else
+ collect i)))
+
+ (unless (native-compile-async-skip-p file load selector)
+ (let* ((out-filename (comp-el-to-eln-filename file))
+ (out-dir (file-name-directory out-filename)))
+ (unless (file-exists-p out-dir)
+ (make-directory out-dir t))
+ (if (file-writable-p out-filename)
+ (setf comp-files-queue
+ (append comp-files-queue `((,file . ,load)))
+ added-something t)
+ (display-warning 'comp
+ (format "No write access for %s skipping."
+ out-filename)))))))
+ ;; Perhaps nothing passed `native-compile-async-skip-p'?
+ (when (and added-something
+ ;; Don't start if there's one already running.
+ (zerop (comp-async-runnings)))
+ (comp-run-async-workers))))
+
+;;;###autoload
+(defun native-compile-async (files &optional recursively load selector)
+ "Compile FILES asynchronously.
+FILES is one file or a list of filenames or directories.
+
+If optional argument RECURSIVELY is non-nil, recurse into
+subdirectories of given directories.
+
+If optional argument LOAD is non-nil, request to load the file
+after compiling.
+
+The optional argument SELECTOR has the following valid values:
+
+nil -- Select all files.
+a string -- A regular expression selecting files with matching names.
+a function -- A function selecting files with matching names.
+
+The variable `native-comp-async-jobs-number' specifies the number
+of (commands) to run simultaneously."
+ ;; Normalize: we only want to pass t or nil, never e.g. `late'.
+ (let ((load (not (not load))))
+ (native--compile-async files recursively load selector)))
+
+(provide 'comp-run)
+
+;;; comp-run.el ends here
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index bdc59703de9..73764eb1d79 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -29,32 +29,26 @@
;;; Code:
(require 'bytecomp)
-(require 'cl-extra)
(require 'cl-lib)
-(require 'cl-macs)
-(require 'cl-seq)
(require 'gv)
(require 'rx)
(require 'subr-x)
(require 'warnings)
+(require 'comp-common)
(require 'comp-cstr)
;; These variables and functions are defined in comp.c
-(defvar native-comp-enable-subr-trampolines)
-(defvar comp-installed-trampolines-h)
+(defvar comp-native-version-dir)
(defvar comp-subr-arities-h)
(defvar native-comp-eln-load-path)
-(defvar comp-native-version-dir)
-(defvar comp-deferred-pending-h)
-(defvar comp--no-native-compile)
+(defvar native-comp-enable-subr-trampolines)
-(declare-function comp-el-to-eln-rel-filename "comp.c")
-(declare-function native-elisp-load "comp.c")
-(declare-function comp--release-ctxt "comp.c")
-(declare-function comp--init-ctxt "comp.c")
(declare-function comp--compile-ctxt-to-file "comp.c")
+(declare-function comp--init-ctxt "comp.c")
+(declare-function comp--release-ctxt "comp.c")
(declare-function comp-el-to-eln-filename "comp.c")
-(declare-function comp--install-trampoline "comp.c")
+(declare-function comp-el-to-eln-rel-filename "comp.c")
+(declare-function native-elisp-load "comp.c")
(defgroup comp nil
"Emacs Lisp native compiler."
@@ -86,33 +80,6 @@ This is intended for debugging the compiler itself.
:safe #'natnump
:version "29.1")
-(defcustom native-comp-verbose 0
- "Compiler verbosity for native compilation, a number between 0 and 3.
-This is intended for debugging the compiler itself.
- 0 no logging.
- 1 final LIMPLE is logged.
- 2 LAP, final LIMPLE, and some pass info are logged.
- 3 max verbosity."
- :type 'natnum
- :risky t
- :version "28.1")
-
-(defcustom native-comp-always-compile nil
- "Non-nil means unconditionally (re-)compile all files."
- :type 'boolean
- :version "28.1")
-
-(defcustom native-comp-jit-compilation-deny-list
- '()
- "List of regexps to exclude matching files from deferred native compilation.
-Files whose names match any regexp are excluded from native compilation."
- :type '(repeat regexp)
- :version "28.1")
-
-(make-obsolete-variable 'native-comp-deferred-compilation-deny-list
- 'native-comp-jit-compilation-deny-list
- "29.1")
-
(defcustom native-comp-bootstrap-deny-list
'()
"List of regexps to exclude files from native compilation during bootstrap.
@@ -121,78 +88,6 @@ during bootstrap."
:type '(repeat regexp)
:version "28.1")
-(defcustom native-comp-never-optimize-functions
- '(;; The following two are mandatory for Emacs to be working
- ;; correctly (see comment in `advice--add-function'). DO NOT
- ;; REMOVE.
- macroexpand rename-buffer)
- "Primitive functions to exclude from trampoline optimization.
-
-Primitive functions included in this list will not be called
-directly by the natively-compiled code, which makes trampolines for
-those primitives unnecessary in case of function redefinition/advice."
- :type '(repeat symbol)
- :version "28.1")
-
-(defcustom native-comp-async-jobs-number 0
- "Default number of subprocesses used for async native compilation.
-Value of zero means to use half the number of the CPU's execution units,
-or one if there's just one execution unit."
- :type 'natnum
- :risky t
- :version "28.1")
-
-(defcustom native-comp-async-cu-done-functions nil
- "List of functions to call when asynchronous compilation of a file is done.
-Each function is called with one argument FILE, the filename whose
-compilation has completed."
- :type 'hook
- :version "28.1")
-
-(defcustom native-comp-async-all-done-hook nil
- "Hook run after completing asynchronous compilation of all input files."
- :type 'hook
- :version "28.1")
-
-(defcustom native-comp-async-env-modifier-form nil
- "Form evaluated before compilation by each asynchronous compilation
subprocess.
-Used to modify the compiler environment."
- :type 'sexp
- :risky t
- :version "28.1")
-
-(defcustom native-comp-async-report-warnings-errors t
- "Whether to report warnings and errors from asynchronous native compilation.
-
-When native compilation happens asynchronously, it can produce
-warnings and errors, some of which might not be emitted by a
-byte-compilation. The typical case for that is native-compiling
-a file that is missing some `require' of a necessary feature,
-while having it already loaded into the environment when
-byte-compiling.
-
-As asynchronous native compilation always starts from a pristine
-environment, it is more sensitive to such omissions, and might be
-unable to compile such Lisp source files correctly.
-
-Set this variable to nil to suppress warnings altogether, or to
-the symbol `silent' to log warnings but not pop up the *Warnings*
-buffer."
- :type '(choice
- (const :tag "Do not report warnings" nil)
- (const :tag "Report and display warnings" t)
- (const :tag "Report but do not display warnings" silent))
- :version "28.1")
-
-(defcustom native-comp-async-query-on-exit nil
- "Whether to query the user about killing async compilations when exiting.
-If this is non-nil, Emacs will ask for confirmation to exit and kill the
-asynchronous native compilations if any are running. If nil, when you
-exit Emacs, it will silently kill those asynchronous compilations even
-if `confirm-kill-processes' is non-nil."
- :type 'boolean
- :version "28.1")
-
(defcustom native-comp-compiler-options nil
"Command line options passed verbatim to GCC compiler.
Note that not all options are meaningful and some options might even
@@ -248,15 +143,6 @@ Emacs Lisp file:
(defvar comp-dry-run nil
"If non-nil, run everything but the C back-end.")
-(defconst comp-valid-source-re (rx ".el" (? ".gz") eos)
- "Regexp to match filename of valid input source files.")
-
-(defconst comp-log-buffer-name "*Native-compile-Log*"
- "Name of the native-compiler log buffer.")
-
-(defconst comp-async-buffer-name "*Async-native-compile-log*"
- "Name of the async compilation buffer log.")
-
(defvar comp-native-compiling nil
"This gets bound to t during native compilation.
Intended to be used by code that needs to work differently when
@@ -291,346 +177,6 @@ For internal use by the test suite only.")
Each function in FUNCTIONS is run after PASS.
Useful to hook into pass checkers.")
-;; FIXME this probably should not be here but... good for now.
-(defconst comp-known-type-specifiers
- `(
- ;; Functions we can trust not to be redefined, or, if redefined,
- ;; to expose the same type. The vast majority of these are
- ;; either pure or primitive; the original list is the union of
- ;; pure + side-effect-free-fns + side-effect-and-error-free-fns:
- (% (function ((or number marker) (or number marker)) number))
- (* (function (&rest (or number marker)) number))
- (+ (function (&rest (or number marker)) number))
- (- (function (&rest (or number marker)) number))
- (/ (function ((or number marker) &rest (or number marker)) number))
- (/= (function ((or number marker) (or number marker)) boolean))
- (1+ (function ((or number marker)) number))
- (1- (function ((or number marker)) number))
- (< (function ((or number marker) &rest (or number marker)) boolean))
- (<= (function ((or number marker) &rest (or number marker)) boolean))
- (= (function ((or number marker) &rest (or number marker)) boolean))
- (> (function ((or number marker) &rest (or number marker)) boolean))
- (>= (function ((or number marker) &rest (or number marker)) boolean))
- (abs (function (number) number))
- (acos (function (number) float))
- (append (function (&rest t) t))
- (aref (function (t fixnum) t))
- (arrayp (function (t) boolean))
- (ash (function (integer integer) integer))
- (asin (function (number) float))
- (assq (function (t list) list))
- (atan (function (number &optional number) float))
- (atom (function (t) boolean))
- (bignump (function (t) boolean))
- (bobp (function () boolean))
- (bolp (function () boolean))
- (bool-vector-count-consecutive
- (function (bool-vector boolean integer) fixnum))
- (bool-vector-count-population (function (bool-vector) fixnum))
- (bool-vector-not (function (bool-vector &optional bool-vector)
bool-vector))
- (bool-vector-p (function (t) boolean))
- (bool-vector-subsetp (function (bool-vector bool-vector) boolean))
- (boundp (function (symbol) boolean))
- (buffer-end (function ((or number marker)) integer))
- (buffer-file-name (function (&optional buffer) (or string null)))
- (buffer-list (function (&optional frame) list))
- (buffer-local-variables (function (&optional buffer) list))
- (buffer-modified-p
- (function (&optional buffer) (or boolean (member autosaved))))
- (buffer-size (function (&optional buffer) integer))
- (buffer-string (function () string))
- (buffer-substring
- (function ((or integer marker) (or integer marker)) string))
- (bufferp (function (t) boolean))
- (byte-code-function-p (function (t) boolean))
- (capitalize (function (or integer string) (or integer string)))
- (car (function (list) t))
- (car-less-than-car (function (list list) boolean))
- (car-safe (function (t) t))
- (case-table-p (function (t) boolean))
- (cdr (function (list) t))
- (cdr-safe (function (t) t))
- (ceiling (function (number &optional number) integer))
- (char-after (function (&optional (or marker integer)) (or fixnum null)))
- (char-before (function (&optional (or marker integer)) (or fixnum null)))
- (char-equal (function (integer integer) boolean))
- (char-or-string-p (function (t) boolean))
- (char-to-string (function (fixnum) string))
- (char-width (function (fixnum) fixnum))
- (characterp (function (t &optional t) boolean))
- (charsetp (function (t) boolean))
- (commandp (function (t &optional t) boolean))
- (compare-strings
- (function (string (or integer marker null) (or integer marker null) string
- (or integer marker null) (or integer marker null)
- &optional t)
- (or (member t) fixnum)))
- (concat (function (&rest sequence) string))
- (cons (function (t t) cons))
- (consp (function (t) boolean))
- (coordinates-in-window-p
- (function (cons window)
- (or cons null
- (member bottom-divider right-divider mode-line header-line
- tab-line left-fringe right-fringe vertical-line
- left-margin right-margin))))
- (copy-alist (function (list) list))
- (copy-marker (function (&optional (or integer marker) boolean) marker))
- (copy-sequence (function (sequence) sequence))
- (copysign (function (float float) float))
- (cos (function (number) float))
- (count-lines
- (function ((or integer marker) (or integer marker) &optional t) integer))
- (current-buffer (function () buffer))
- (current-global-map (function () cons))
- (current-indentation (function () integer))
- (current-local-map (function () (or cons null)))
- (current-minor-mode-maps (function () (or cons null)))
- (current-time (function () cons))
- (current-time-string (function (&optional (or number list)
- (or symbol string cons integer))
- string))
- (current-time-zone (function (&optional (or number list)
- (or symbol string cons integer))
- cons))
- (custom-variable-p (function (symbol) t))
- (decode-char (function (cons t) (or fixnum null)))
- (decode-time (function (&optional (or number list)
- (or symbol string cons integer)
- symbol)
- cons))
- (default-boundp (function (symbol) boolean))
- (default-value (function (symbol) t))
- (degrees-to-radians (function (number) float))
- (documentation
- (function ((or function symbol subr) &optional t) (or null string)))
- (downcase (function ((or fixnum string)) (or fixnum string)))
- (elt (function (sequence integer) t))
- (encode-char (function (fixnum symbol) (or fixnum null)))
- (encode-time (function (cons &rest t) cons))
- (eobp (function () boolean))
- (eolp (function () boolean))
- (eq (function (t t) boolean))
- (eql (function (t t) boolean))
- (equal (function (t t) boolean))
- (error-message-string (function (list) string))
- (eventp (function (t) boolean))
- (exp (function (number) float))
- (expt (function (number number) number))
- (fboundp (function (symbol) boolean))
- (fceiling (function (float) float))
- (featurep (function (symbol &optional symbol) boolean))
- (ffloor (function (float) float))
- (file-directory-p (function (string) boolean))
- (file-exists-p (function (string) boolean))
- (file-locked-p (function (string) (or boolean string)))
- (file-name-absolute-p (function (string) boolean))
- (file-newer-than-file-p (function (string string) boolean))
- (file-readable-p (function (string) boolean))
- (file-symlink-p (function (string) (or boolean string)))
- (file-writable-p (function (string) boolean))
- (fixnump (function (t) boolean))
- (float (function (number) float))
- (float-time (function (&optional (or number list)) float))
- (floatp (function (t) boolean))
- (floor (function (number &optional number) integer))
- (following-char (function () fixnum))
- (format (function (string &rest t) string))
- (format-time-string (function (string &optional (or number list)
- (or symbol string cons integer))
- string))
- (frame-first-window (function ((or frame window)) window))
- (frame-root-window (function (&optional (or frame window)) window))
- (frame-selected-window (function (&optional (or frame window)) window))
- (frame-visible-p (function (frame) (or boolean (member icon))))
- (framep (function (t) symbol))
- (fround (function (float) float))
- (ftruncate (function (float) float))
- (get (function (symbol symbol) t))
- (get-buffer (function ((or buffer string)) (or buffer null)))
- (get-buffer-window
- (function (&optional (or buffer string) (or symbol (integer 0 0)))
- (or null window)))
- (get-file-buffer (function (string) (or null buffer)))
- (get-largest-window (function (&optional t t t) (or window null)))
- (get-lru-window (function (&optional t t t) (or window null)))
- (getenv (function (string &optional frame) (or null string)))
- (gethash (function (t hash-table &optional t) t))
- (hash-table-count (function (hash-table) integer))
- (hash-table-p (function (t) boolean))
- (identity (function (t) t))
- (ignore (function (&rest t) null))
- (int-to-string (function (number) string))
- (integer-or-marker-p (function (t) boolean))
- (integerp (function (t) boolean))
- (interactive-p (function () boolean))
- (intern-soft (function ((or string symbol) &optional vector) symbol))
- (invocation-directory (function () string))
- (invocation-name (function () string))
- (isnan (function (float) boolean))
- (keymap-parent (function (cons) (or cons null)))
- (keymapp (function (t) boolean))
- (keywordp (function (t) boolean))
- (last (function (list &optional integer) list))
- (lax-plist-get (function (list t) t))
- (ldexp (function (number integer) float))
- (length (function (t) (integer 0 *)))
- (length< (function (sequence fixnum) boolean))
- (length= (function (sequence fixnum) boolean))
- (length> (function (sequence fixnum) boolean))
- (line-beginning-position (function (&optional integer) integer))
- (line-end-position (function (&optional integer) integer))
- (list (function (&rest t) list))
- (listp (function (t) boolean))
- (local-variable-if-set-p (function (symbol &optional buffer) boolean))
- (local-variable-p (function (symbol &optional buffer) boolean))
- (locale-info (function ((member codeset days months paper)) (or null
string)))
- (log (function (number number) float))
- (log10 (function (number) float))
- (logand (function (&rest (or integer marker)) integer))
- (logb (function (number) integer))
- (logcount (function (integer) integer))
- (logior (function (&rest (or integer marker)) integer))
- (lognot (function (integer) integer))
- (logxor (function (&rest (or integer marker)) integer))
- ;; (lsh (function ((integer ,most-negative-fixnum *) integer) integer)) ?
- (lsh (function (integer integer) integer))
- (make-byte-code
- (function ((or fixnum list) string vector integer &optional string t
- &rest t)
- vector))
- (make-list (function (integer t) list))
- (make-marker (function () marker))
- (make-string (function (integer fixnum &optional t) string))
- (make-symbol (function (string) symbol))
- (mark (function (&optional t) (or integer null)))
- (mark-marker (function () marker))
- (marker-buffer (function (marker) (or buffer null)))
- (markerp (function (t) boolean))
- (max (function ((or number marker) &rest (or number marker)) number))
- (max-char (function (&optional t) fixnum))
- (member (function (t list) list))
- (memory-limit (function () integer))
- (memq (function (t list) list))
- (memql (function (t list) list))
- (min (function ((or number marker) &rest (or number marker)) number))
- (minibuffer-selected-window (function () (or window null)))
- (minibuffer-window (function (&optional frame) window))
- (mod
- (function ((or number marker) (or number marker))
- (or (integer 0 *) (float 0 *))))
- (mouse-movement-p (function (t) boolean))
- (multibyte-char-to-unibyte (function (fixnum) fixnum))
- (natnump (function (t) boolean))
- (next-window (function (&optional window t t) window))
- (nlistp (function (t) boolean))
- (not (function (t) boolean))
- (nth (function (integer list) t))
- (nthcdr (function (integer t) t))
- (null (function (t) boolean))
- (number-or-marker-p (function (t) boolean))
- (number-to-string (function (number) string))
- (numberp (function (t) boolean))
- (one-window-p (function (&optional t t) boolean))
- (overlayp (function (t) boolean))
- (parse-colon-path (function (string) cons))
- (plist-get (function (list t &optional t) t))
- (plist-member (function (list t &optional t) list))
- (point (function () integer))
- (point-marker (function () marker))
- (point-max (function () integer))
- (point-min (function () integer))
- (preceding-char (function () fixnum))
- (previous-window (function (&optional window t t) window))
- (prin1-to-string (function (t &optional t t) string))
- (processp (function (t) boolean))
- (proper-list-p (function (t) (or fixnum null)))
- (propertize (function (string &rest t) string))
- (radians-to-degrees (function (number) float))
- (rassoc (function (t list) list))
- (rassq (function (t list) list))
- (read-from-string (function (string &optional integer integer) cons))
- (recent-keys (function (&optional (or cons null)) vector))
- (recursion-depth (function () integer))
- (regexp-opt (function (list) string))
- (regexp-quote (function (string) string))
- (region-beginning (function () integer))
- (region-end (function () integer))
- (reverse (function (sequence) sequence))
- (round (function (number &optional number) integer))
- (safe-length (function (t) integer))
- (selected-frame (function () frame))
- (selected-window (function () window))
- (sequencep (function (t) boolean))
- (sin (function (number) float))
- (sqrt (function (number) float))
- (standard-case-table (function () char-table))
- (standard-syntax-table (function () char-table))
- (string (function (&rest fixnum) string))
- (string-as-multibyte (function (string) string))
- (string-as-unibyte (function (string) string))
- (string-equal (function ((or string symbol) (or string symbol)) boolean))
- (string-lessp (function ((or string symbol) (or string symbol)) boolean))
- (string-make-multibyte (function (string) string))
- (string-make-unibyte (function (string) string))
- (string-search (function (string string &optional integer) (or integer
null)))
- (string-to-char (function (string) fixnum))
- (string-to-multibyte (function (string) string))
- (string-to-number (function (string &optional integer) number))
- (string-to-syntax (function (string) (or cons null)))
- (string< (function ((or string symbol) (or string symbol)) boolean))
- (string= (function ((or string symbol) (or string symbol)) boolean))
- (stringp (function (t) boolean))
- (subrp (function (t) boolean))
- (substring
- (function ((or string vector) &optional integer integer) (or string
vector)))
- (sxhash (function (t) integer))
- (sxhash-eq (function (t) integer))
- (sxhash-eql (function (t) integer))
- (sxhash-equal (function (t) integer))
- (symbol-function (function (symbol) t))
- (symbol-name (function (symbol) string))
- (symbol-plist (function (symbol) list))
- (symbol-value (function (symbol) t))
- (symbolp (function (t) boolean))
- (syntax-table (function () char-table))
- (syntax-table-p (function (t) boolean))
- (tan (function (number) float))
- (this-command-keys (function () string))
- (this-command-keys-vector (function () vector))
- (this-single-command-keys (function () vector))
- (this-single-command-raw-keys (function () vector))
- (time-convert (function ((or number list) &optional (or symbol integer))
- (or cons number)))
- (truncate (function (number &optional number) integer))
- (type-of (function (t) symbol))
- (unibyte-char-to-multibyte (function (fixnum) fixnum)) ;; byte is fixnum
- (upcase (function ((or fixnum string)) (or fixnum string)))
- (user-full-name (function (&optional integer) (or string null)))
- (user-login-name (function (&optional integer) (or string null)))
- (user-original-login-name (function (&optional integer) (or string null)))
- (user-real-login-name (function () string))
- (user-real-uid (function () integer))
- (user-uid (function () integer))
- (vconcat (function (&rest sequence) vector))
- (vector (function (&rest t) vector))
- (vectorp (function (t) boolean))
- (visible-frame-list (function () list))
- (wholenump (function (t) boolean))
- (window-configuration-p (function (t) boolean))
- (window-live-p (function (t) boolean))
- (window-valid-p (function (t) boolean))
- (windowp (function (t) boolean))
- (zerop (function (number) boolean))
- ;; Type hints
- (comp-hint-fixnum (function (t) fixnum))
- (comp-hint-cons (function (t) cons))
- ;; Non returning functions
- (throw (function (t t) nil))
- (error (function (string &rest t) nil))
- (signal (function (symbol t) nil)))
- "Alist used for type propagation.")
-
(defconst comp-known-func-cstr-h
(cl-loop
with comp-ctxt = (make-comp-cstr-ctxt)
@@ -697,33 +243,6 @@ Useful to hook into pass checkers.")
comp-hint-cons)
"List of fake functions used to give compiler hints.")
-(defconst comp-limple-sets '(set
- setimm
- set-par-to-local
- set-args-to-local
- set-rest-args-to-local)
- "Limple set operators.")
-
-(defconst comp-limple-assignments `(assume
- fetch-handler
- ,@comp-limple-sets)
- "Limple operators that clobber the first m-var argument.")
-
-(defconst comp-limple-calls '(call
- callref
- direct-call
- direct-callref)
- "Limple operators used to call subrs.")
-
-(defconst comp-limple-branches '(jump cond-jump)
- "Limple operators used for conditional and unconditional branches.")
-
-(defconst comp-limple-ops `(,@comp-limple-calls
- ,@comp-limple-assignments
- ,@comp-limple-branches
- return)
- "All Limple operators.")
-
(defvar comp-func nil
"Bound to the current function by most passes.")
@@ -741,30 +260,6 @@ Useful to hook into pass checkers.")
(defvar comp-no-spawn nil
"Non-nil don't spawn native compilation processes.")
-(defconst comp-warn-primitives
- '(null memq gethash and subrp not subr-native-elisp-p
- comp--install-trampoline concat if symbolp symbol-name make-string
- length aset aref length> mapcar expand-file-name
- file-name-as-directory file-exists-p native-elisp-load)
- "List of primitives we want to warn about in case of redefinition.
-This are essential for the trampoline machinery to work properly.")
-
-;; Moved early to avoid circularity when comp.el is loaded and
-;; `macroexpand' needs to be advised (bug#47049).
-;;;###autoload
-(defun comp-subr-trampoline-install (subr-name)
- "Make SUBR-NAME effectively advice-able when called from native code."
- (when (memq subr-name comp-warn-primitives)
- (warn "Redefining `%s' might break native compilation of trampolines."
- subr-name))
- (unless (or (null native-comp-enable-subr-trampolines)
- (memq subr-name native-comp-never-optimize-functions)
- (gethash subr-name comp-installed-trampolines-h))
- (cl-assert (subr-primitive-p (symbol-function subr-name)))
- (when-let ((trampoline (or (comp-trampoline-search subr-name)
- (comp-trampoline-compile subr-name))))
- (comp--install-trampoline subr-name trampoline))))
-
(cl-defstruct (comp-vec (:copier nil))
"A re-sizable vector like object."
@@ -1030,16 +525,6 @@ In use by the back-end."
-(defun comp-ensure-native-compiler ()
- "Make sure Emacs has native compiler support and libgccjit can be loaded.
-Signal an error otherwise.
-To be used by all entry points."
- (cond
- ((null (featurep 'native-compile))
- (error "Emacs was not compiled with native compiler support
(--with-native-compilation)"))
- ((null (native-comp-available-p))
- (error "Cannot find libgccjit library"))))
-
(defun comp-equality-fun-p (function)
"Equality functions predicate for FUNCTION."
(when (memq function '(eq eql equal)) t))
@@ -1109,71 +594,6 @@ Assume allocation class `d-default' as default."
;;; Log routines.
-(defconst comp-limple-lock-keywords
- `((,(rx bol "(comment" (1+ not-newline)) . font-lock-comment-face)
- (,(rx "#(" (group-n 1 "mvar"))
- (1 font-lock-function-name-face))
- (,(rx bol "(" (group-n 1 "phi"))
- (1 font-lock-variable-name-face))
- (,(rx bol "(" (group-n 1 (or "return" "unreachable")))
- (1 font-lock-warning-face))
- (,(rx (group-n 1 (or "entry"
- (seq (or "entry_" "entry_fallback_" "bb_")
- (1+ num) (? (or "_latch"
- (seq "_cstrs_" (1+ num))))))))
- (1 font-lock-constant-face))
- (,(rx-to-string
- `(seq "(" (group-n 1 (or ,@(mapcar #'symbol-name comp-limple-ops)))))
- (1 font-lock-keyword-face)))
- "Highlights used by `native-comp-limple-mode'.")
-
-(define-derived-mode native-comp-limple-mode fundamental-mode "LIMPLE"
- "Syntax-highlight LIMPLE IR."
- (setf font-lock-defaults '(comp-limple-lock-keywords)))
-
-(cl-defun comp-log (data &optional (level 1) quoted)
- "Log DATA at LEVEL.
-LEVEL is a number from 1-3, and defaults to 1; if it is less
-than `native-comp-verbose', do nothing. If `noninteractive', log
-with `message'. Otherwise, log with `comp-log-to-buffer'."
- (when (>= native-comp-verbose level)
- (if noninteractive
- (cl-typecase data
- (atom (message "%s" data))
- (t (dolist (elem data)
- (message "%s" elem))))
- (comp-log-to-buffer data quoted))))
-
-(cl-defun comp-log-to-buffer (data &optional quoted)
- "Log DATA to `comp-log-buffer-name'."
- (let* ((print-f (if quoted #'prin1 #'princ))
- (log-buffer
- (or (get-buffer comp-log-buffer-name)
- (with-current-buffer (get-buffer-create comp-log-buffer-name)
- (unless (derived-mode-p 'compilation-mode)
- (emacs-lisp-compilation-mode))
- (current-buffer))))
- (log-window (get-buffer-window log-buffer))
- (inhibit-read-only t)
- at-end-p)
- (with-current-buffer log-buffer
- (unless (eq major-mode 'native-comp-limple-mode)
- (native-comp-limple-mode))
- (when (= (point) (point-max))
- (setf at-end-p t))
- (save-excursion
- (goto-char (point-max))
- (cl-typecase data
- (atom (funcall print-f data log-buffer))
- (t (dolist (elem data)
- (funcall print-f elem log-buffer)
- (insert "\n"))))
- (insert "\n"))
- (when (and at-end-p log-window)
- ;; When log window's point is at the end, follow the tail.
- (with-selected-window log-window
- (goto-char (point-max)))))))
-
(defun comp-prettyformat-mvar (mvar)
(format "#(mvar %s %s %S)"
(comp-mvar-id mvar)
@@ -1319,86 +739,31 @@ clashes."
nil ".eln")))
(let* ((f (symbol-function function-name))
(byte-code (byte-compile function-name))
- (c-name (comp-c-func-name function-name "F"))
- (func
- (if (comp-lex-byte-func-p byte-code)
- (make-comp-func-l :name function-name
- :c-name c-name
- :doc (documentation f t)
- :int-spec (interactive-form f)
- :command-modes (command-modes f)
- :speed (comp-spill-speed function-name)
- :pure (comp-spill-decl-spec function-name
- 'pure))
- (make-comp-func-d :name function-name
- :c-name c-name
- :doc (documentation f t)
- :int-spec (interactive-form f)
- :command-modes (command-modes f)
- :speed (comp-spill-speed function-name)
- :pure (comp-spill-decl-spec function-name
- 'pure)))))
+ (c-name (comp-c-func-name function-name "F")))
(when (byte-code-function-p f)
(signal 'native-compiler-error
'("can't native compile an already byte-compiled function")))
- (setf (comp-func-byte-func func) byte-code)
- (let ((lap (byte-to-native-lambda-lap
- (gethash (aref (comp-func-byte-func func) 1)
- byte-to-native-lambdas-h))))
- (cl-assert lap)
- (comp-log lap 2 t)
- (if (comp-func-l-p func)
- (let ((arg-list (aref (comp-func-byte-func func) 0)))
- (setf (comp-func-l-args func)
- (comp-decrypt-arg-list arg-list function-name)))
- (setf (comp-func-d-lambda-list func) (cadr f)))
- (setf (comp-func-lap func)
- lap
- (comp-func-frame-size func)
- (comp-byte-frame-size (comp-func-byte-func func))
- (comp-ctxt-top-level-forms comp-ctxt)
+ (setf (comp-ctxt-top-level-forms comp-ctxt)
(list (make-byte-to-native-func-def :name function-name
- :c-name c-name)))
- (comp-add-func-to-ctxt func))))
+ :c-name c-name
+ :byte-func byte-code)))
+ (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)))
(cl-defmethod comp-spill-lap-function ((form list))
"Byte-compile FORM, spilling data from the byte compiler."
- (unless (eq (car-safe form) 'lambda)
+ (unless (memq (car-safe form) '(lambda closure))
(signal 'native-compiler-error
- '("Cannot native-compile, form is not a lambda")))
+ '("Cannot native-compile, form is not a lambda or closure")))
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt)
(make-temp-file "comp-lambda-" nil ".eln")))
(let* ((byte-code (byte-compile form))
- (c-name (comp-c-func-name "anonymous-lambda" "F"))
- (func (if (comp-lex-byte-func-p byte-code)
- (make-comp-func-l :c-name c-name
- :doc (documentation form t)
- :int-spec (interactive-form form)
- :command-modes (command-modes form)
- :speed (comp-ctxt-speed comp-ctxt))
- (make-comp-func-d :c-name c-name
- :doc (documentation form t)
- :int-spec (interactive-form form)
- :command-modes (command-modes form)
- :speed (comp-ctxt-speed comp-ctxt)))))
- (let ((lap (byte-to-native-lambda-lap
- (gethash (aref byte-code 1)
- byte-to-native-lambdas-h))))
- (cl-assert lap)
- (comp-log lap 2 t)
- (if (comp-func-l-p func)
- (setf (comp-func-l-args func)
- (comp-decrypt-arg-list (aref byte-code 0) byte-code))
- (setf (comp-func-d-lambda-list func) (cadr form)))
- (setf (comp-func-lap func) lap
- (comp-func-frame-size func) (comp-byte-frame-size
- byte-code))
- (setf (comp-func-byte-func func) byte-code
- (comp-ctxt-top-level-forms comp-ctxt)
+ (c-name (comp-c-func-name "anonymous-lambda" "F")))
+ (setf (comp-ctxt-top-level-forms comp-ctxt)
(list (make-byte-to-native-func-def :name '--anonymous-lambda
- :c-name c-name)))
- (comp-add-func-to-ctxt func))))
+ :c-name c-name
+ :byte-func byte-code)))
+ (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)))
(defun comp-intern-func-in-ctxt (_ obj)
"Given OBJ of type `byte-to-native-lambda', create a function in
`comp-ctxt'."
@@ -3844,19 +3209,6 @@ Prepare every function for final compilation and drive
the C back-end."
;; Primitive function advice machinery
-(defun comp-eln-load-path-eff ()
- "Return a list of effective eln load directories.
-Account for `native-comp-eln-load-path' and `comp-native-version-dir'."
- (mapcar (lambda (dir)
- (expand-file-name comp-native-version-dir
- (file-name-as-directory
- (expand-file-name dir invocation-directory))))
- native-comp-eln-load-path))
-
-(defun comp-trampoline-filename (subr-name)
- "Given SUBR-NAME return the filename containing the trampoline."
- (concat (comp-c-func-name subr-name "subr--trampoline-" t) ".eln"))
-
(defun comp-make-lambda-list-from-subr (subr)
"Given SUBR return the equivalent lambda-list."
(pcase-let ((`(,min . ,max) (subr-arity subr))
@@ -3872,16 +3224,6 @@ Account for `native-comp-eln-load-path' and
`comp-native-version-dir'."
(push (gensym "arg") lambda-list))
(reverse lambda-list)))
-(defun comp-trampoline-search (subr-name)
- "Search a trampoline file for SUBR-NAME.
-Return the trampoline if found or nil otherwise."
- (cl-loop
- with rel-filename = (comp-trampoline-filename subr-name)
- for dir in (comp-eln-load-path-eff)
- for filename = (expand-file-name rel-filename dir)
- when (file-exists-p filename)
- do (cl-return (native-elisp-load filename))))
-
(defun comp--trampoline-abs-filename (subr-name)
"Return the absolute filename for a trampoline for SUBR-NAME."
(cl-loop
@@ -3907,6 +3249,8 @@ Return the trampoline if found or nil otherwise."
(make-temp-file (file-name-sans-extension rel-filename) nil ".eln"
nil))))
+;; Called from comp-run.el
+;;;###autoload
(defun comp-trampoline-compile (subr-name)
"Synthesize compile and return a trampoline for SUBR-NAME."
(let* ((lambda-list (comp-make-lambda-list-from-subr
@@ -3985,174 +3329,6 @@ session."
(when newfile
(rename-file newfile oldfile)))))
-(defvar comp-files-queue ()
- "List of Emacs Lisp files to be compiled.")
-
-(defvar comp-async-compilations (make-hash-table :test #'equal)
- "Hash table file-name -> async compilation process.")
-
-(defun comp-async-runnings ()
- "Return the number of async compilations currently running.
-This function has the side effect of cleaning-up finished
-processes from `comp-async-compilations'"
- (cl-loop
- for file-name in (cl-loop
- for file-name being each hash-key of
comp-async-compilations
- for prc = (gethash file-name comp-async-compilations)
- unless (process-live-p prc)
- collect file-name)
- do (remhash file-name comp-async-compilations))
- (hash-table-count comp-async-compilations))
-
-(defvar comp-num-cpus nil)
-(defun comp-effective-async-max-jobs ()
- "Compute the effective number of async jobs."
- (if (zerop native-comp-async-jobs-number)
- (or comp-num-cpus
- (setf comp-num-cpus
- (max 1 (/ (num-processors) 2))))
- native-comp-async-jobs-number))
-
-(defvar comp-last-scanned-async-output nil)
-(make-variable-buffer-local 'comp-last-scanned-async-output)
-(defun comp-accept-and-process-async-output (process)
- "Accept PROCESS output and check for diagnostic messages."
- (if native-comp-async-report-warnings-errors
- (let ((warning-suppress-types
- (if (eq native-comp-async-report-warnings-errors 'silent)
- (cons '(comp) warning-suppress-types)
- warning-suppress-types)))
- (with-current-buffer (process-buffer process)
- (save-excursion
- (accept-process-output process)
- (goto-char (or comp-last-scanned-async-output (point-min)))
- (while (re-search-forward "^.*?\\(?:Error\\|Warning\\): .*$"
- nil t)
- (display-warning 'comp (match-string 0)))
- (setq comp-last-scanned-async-output (point-max)))))
- (accept-process-output process)))
-
-(defun comp-run-async-workers ()
- "Start compiling files from `comp-files-queue' asynchronously.
-When compilation is finished, run `native-comp-async-all-done-hook' and
-display a message."
- (cl-assert (null comp-no-spawn))
- (if (or comp-files-queue
- (> (comp-async-runnings) 0))
- (unless (>= (comp-async-runnings) (comp-effective-async-max-jobs))
- (cl-loop
- for (source-file . load) = (pop comp-files-queue)
- while source-file
- do (cl-assert (string-match-p comp-valid-source-re source-file) nil
- "`comp-files-queue' should be \".el\" files: %s"
- source-file)
- when (or native-comp-always-compile
- load ; Always compile when the compilation is
- ; commanded for late load.
- ;; Skip compilation if `comp-el-to-eln-filename' fails
- ;; to find a writable directory.
- (with-demoted-errors "Async compilation :%S"
- (file-newer-than-file-p
- source-file (comp-el-to-eln-filename source-file))))
- do (let* ((expr `((require 'comp)
- (setq comp-async-compilation t
- warning-fill-column most-positive-fixnum)
- ,(let ((set (list 'setq)))
- (dolist (var '(comp-file-preloaded-p
- native-compile-target-directory
- native-comp-speed
- native-comp-debug
- native-comp-verbose
- comp-libgccjit-reproducer
- native-comp-eln-load-path
- native-comp-compiler-options
- native-comp-driver-options
- load-path
- backtrace-line-length
- byte-compile-warnings
- ;; package-load-list
- ;; package-user-dir
- ;; package-directory-list
- ))
- (when (boundp var)
- (push var set)
- (push `',(symbol-value var) set)))
- (nreverse set))
- ;; FIXME: Activating all packages would align the
- ;; functionality offered with what is usually done
- ;; for ELPA packages (and thus fix some compilation
- ;; issues with some ELPA packages), but it's too
- ;; blunt an instrument (e.g. we don't even know if
- ;; we're compiling such an ELPA package at
- ;; this point).
- ;;(package-activate-all)
- ,native-comp-async-env-modifier-form
- (message "Compiling %s..." ,source-file)
- (comp--native-compile ,source-file ,(and load t))))
- (source-file1 source-file) ;; Make the closure works :/
- (temp-file (make-temp-file
- (concat "emacs-async-comp-"
- (file-name-base source-file) "-")
- nil ".el"))
- (expr-strings (let ((print-length nil)
- (print-level nil))
- (mapcar #'prin1-to-string expr)))
- (_ (progn
- (with-temp-file temp-file
- (mapc #'insert expr-strings))
- (comp-log "\n")
- (mapc #'comp-log expr-strings)))
- (load1 load)
- (default-directory invocation-directory)
- (process (make-process
- :name (concat "Compiling: " source-file)
- :buffer (with-current-buffer
- (get-buffer-create
- comp-async-buffer-name)
- (unless (derived-mode-p
'compilation-mode)
- (emacs-lisp-compilation-mode))
- (current-buffer))
- :command (list
- (expand-file-name invocation-name
- invocation-directory)
- "-no-comp-spawn" "-Q" "--batch"
- "--eval"
- ;; Suppress Abort dialogs on MS-Windows
- "(setq w32-disable-abort-dialog t)"
- "-l" temp-file)
- :sentinel
- (lambda (process _event)
- (run-hook-with-args
- 'native-comp-async-cu-done-functions
- source-file)
- (comp-accept-and-process-async-output process)
- (ignore-errors (delete-file temp-file))
- (let ((eln-file (comp-el-to-eln-filename
- source-file1)))
- (when (and load1
- (zerop (process-exit-status
- process))
- (file-exists-p eln-file))
- (native-elisp-load eln-file
- (eq load1 'late))))
- (comp-run-async-workers))
- :noquery (not native-comp-async-query-on-exit))))
- (puthash source-file process comp-async-compilations))
- when (>= (comp-async-runnings) (comp-effective-async-max-jobs))
- do (cl-return)))
- ;; No files left to compile and all processes finished.
- (run-hooks 'native-comp-async-all-done-hook)
- (with-current-buffer (get-buffer-create comp-async-buffer-name)
- (save-excursion
- (unless (derived-mode-p 'compilation-mode)
- (emacs-lisp-compilation-mode))
- (let ((inhibit-read-only t))
- (goto-char (point-max))
- (insert "Compilation finished.\n"))))
- ;; `comp-deferred-pending-h' should be empty at this stage.
- ;; Reset it anyway.
- (clrhash comp-deferred-pending-h)))
-
(defun comp--native-compile (function-or-file &optional with-late-load output)
"Compile FUNCTION-OR-FILE into native code.
When WITH-LATE-LOAD is non-nil, mark the compilation unit for late
@@ -4235,102 +3411,6 @@ the deferred compilation mechanism."
(ignore-errors (delete-file (comp-ctxt-output comp-ctxt))))
(t (delete-file (comp-ctxt-output comp-ctxt))))))))))
-(defun native-compile-async-skip-p (file load selector)
- "Return non-nil if FILE's compilation should be skipped.
-
-LOAD and SELECTOR work as described in `native--compile-async'."
- ;; Make sure we are not already compiling `file' (bug#40838).
- (or (gethash file comp-async-compilations)
- (gethash (file-name-with-extension file "elc") comp--no-native-compile)
- (cond
- ((null selector) nil)
- ((functionp selector) (not (funcall selector file)))
- ((stringp selector) (not (string-match-p selector file)))
- (t (error "SELECTOR must be a function a regexp or nil")))
- ;; Also exclude files from deferred compilation if
- ;; any of the regexps in
- ;; `native-comp-jit-compilation-deny-list' matches.
- (and (eq load 'late)
- (cl-some (lambda (re)
- (string-match-p re file))
- native-comp-jit-compilation-deny-list))))
-
-;;;###autoload
-(defun native--compile-async (files &optional recursively load selector)
- ;; BEWARE, this function is also called directly from C.
- "Compile FILES asynchronously.
-FILES is one filename or a list of filenames or directories.
-
-If optional argument RECURSIVELY is non-nil, recurse into
-subdirectories of given directories.
-
-If optional argument LOAD is non-nil, request to load the file
-after compiling.
-
-The optional argument SELECTOR has the following valid values:
-
-nil -- Select all files.
-a string -- A regular expression selecting files with matching names.
-a function -- A function selecting files with matching names.
-
-The variable `native-comp-async-jobs-number' specifies the number
-of (commands) to run simultaneously.
-
-LOAD can also be the symbol `late'. This is used internally if
-the byte code has already been loaded when this function is
-called. It means that we request the special kind of load
-necessary in that situation, called \"late\" loading.
-
-During a \"late\" load, instead of executing all top-level forms
-of the original files, only function definitions are
-loaded (paying attention to have these effective only if the
-bytecode definition was not changed in the meantime)."
- (comp-ensure-native-compiler)
- (unless (member load '(nil t late))
- (error "LOAD must be nil, t or 'late"))
- (unless (listp files)
- (setf files (list files)))
- (let ((added-something nil)
- file-list)
- (dolist (file-or-dir files)
- (cond ((file-directory-p file-or-dir)
- (dolist (file (if recursively
- (directory-files-recursively
- file-or-dir comp-valid-source-re)
- (directory-files file-or-dir
- t comp-valid-source-re)))
- (push file file-list)))
- ((file-exists-p file-or-dir) (push file-or-dir file-list))
- (t (signal 'native-compiler-error
- (list "Not a file nor directory" file-or-dir)))))
- (dolist (file file-list)
- (if-let ((entry (cl-find file comp-files-queue :key #'car :test
#'string=)))
- ;; Most likely the byte-compiler has requested a deferred
- ;; compilation, so update `comp-files-queue' to reflect that.
- (unless (or (null load)
- (eq load (cdr entry)))
- (setf comp-files-queue
- (cl-substitute (cons file load) (car entry) comp-files-queue
- :key #'car :test #'string=)))
-
- (unless (native-compile-async-skip-p file load selector)
- (let* ((out-filename (comp-el-to-eln-filename file))
- (out-dir (file-name-directory out-filename)))
- (unless (file-exists-p out-dir)
- (make-directory out-dir t))
- (if (file-writable-p out-filename)
- (setf comp-files-queue
- (append comp-files-queue `((,file . ,load)))
- added-something t)
- (display-warning 'comp
- (format "No write access for %s skipping."
- out-filename)))))))
- ;; Perhaps nothing passed `native-compile-async-skip-p'?
- (when (and added-something
- ;; Don't start if there's one already running.
- (zerop (comp-async-runnings)))
- (comp-run-async-workers))))
-
;;; Compiler entry points.
@@ -4438,29 +3518,6 @@ variable \"NATIVE_DISABLED\" is set, only byte compile."
(comp-write-bytecode-file eln-file)
(setq command-line-args-left (cdr command-line-args-left)))))
-;;;###autoload
-(defun native-compile-async (files &optional recursively load selector)
- "Compile FILES asynchronously.
-FILES is one file or a list of filenames or directories.
-
-If optional argument RECURSIVELY is non-nil, recurse into
-subdirectories of given directories.
-
-If optional argument LOAD is non-nil, request to load the file
-after compiling.
-
-The optional argument SELECTOR has the following valid values:
-
-nil -- Select all files.
-a string -- A regular expression selecting files with matching names.
-a function -- A function selecting files with matching names.
-
-The variable `native-comp-async-jobs-number' specifies the number
-of (commands) to run simultaneously."
- ;; Normalize: we only want to pass t or nil, never e.g. `late'.
- (let ((load (not (not load))))
- (native--compile-async files recursively load selector)))
-
(defun native-compile-prune-cache ()
"Remove .eln files that aren't applicable to the current Emacs invocation."
(interactive)
@@ -4491,29 +3548,6 @@ of (commands) to run simultaneously."
(delete-directory subdir))))))
(message "Cache cleared"))
-;;;###autoload
-(defun comp-function-type-spec (function)
- "Return the type specifier of FUNCTION.
-
-This function returns a cons cell whose car is the function
-specifier, and cdr is a symbol, either `inferred' or `know'.
-If the symbol is `inferred', the type specifier is automatically
-inferred from the code itself by the native compiler; if it is
-`know', the type specifier comes from `comp-known-type-specifiers'."
- (let ((kind 'know)
- type-spec )
- (when-let ((res (gethash function comp-known-func-cstr-h)))
- (setf type-spec (comp-cstr-to-type-spec res)))
- (let ((f (and (symbolp function)
- (symbol-function function))))
- (when (and f
- (null type-spec)
- (subr-native-elisp-p f))
- (setf kind 'inferred
- type-spec (subr-type f))))
- (when type-spec
- (cons type-spec kind))))
-
(provide 'comp)
;; LocalWords: limplified limplification limplify Limple LIMPLE libgccjit elc
eln
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index d727bc94ec5..61d8341bdad 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -152,7 +152,7 @@ mode.")
(when (and noninteractive (get symbol 'ert--test))
;; Make sure duplicated tests are discovered since the older test would
;; be ignored silently otherwise.
- (error "Test `%s' redefined" symbol))
+ (error "Test `%s' redefined (or loaded twice)" symbol))
(define-symbol-prop symbol 'ert--test definition)
definition)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index ce5467f3c5c..98efb4c9c28 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -389,7 +389,7 @@ is also interactive. There are 3 cases:
`(advice--add-function ,how (gv-ref ,(advice--normalize-place place))
,function ,props))
-(declare-function comp-subr-trampoline-install "comp")
+(declare-function comp-subr-trampoline-install "comp-run")
;;;###autoload
(defun advice--add-function (how ref function props)
@@ -407,7 +407,7 @@ is also interactive. There are 3 cases:
(unless (memq subr-name '(macroexpand rename-buffer))
;; Must require explicitly as during bootstrap we have no
;; autoloads.
- (require 'comp)
+ (require 'comp-run)
(comp-subr-trampoline-install subr-name))))
(let* ((name (cdr (assq 'name props)))
(a (advice--member-p (or name function) (if name t) (gv-deref ref))))
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index ae0038b45e6..c23dd5a36da 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -350,6 +350,7 @@ MUTABLE is a list of symbols indicating which of the
BINDINGS
should be mutable.
No checking is performed."
(declare (indent 3) (debug (sexp (&rest (sexp form)) sexp def-body)))
+ (cl-assert lexical-binding) ;Can't work in dynbind dialect.
;; FIXME: Fundamentally `oclosure-lambda' should be a special form.
;; We define it here as a macro which expands to something that
;; looks like "normal code" in order to avoid backward compatibility
diff --git a/lisp/emacs-lisp/warnings.el b/lisp/emacs-lisp/warnings.el
index 31b840d6c83..b99b1d2ae29 100644
--- a/lisp/emacs-lisp/warnings.el
+++ b/lisp/emacs-lisp/warnings.el
@@ -106,6 +106,7 @@ so only the element (FOO) will match it."
:type '(repeat (repeat symbol))
:version "22.1")
+;;;###autoload
(defcustom warning-suppress-types nil
"List of warning types not to display immediately.
If any element of this list matches the TYPE argument to `display-warning',
diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el
index b3812470a4d..e23380eb936 100644
--- a/lisp/erc/erc-stamp.el
+++ b/lisp/erc/erc-stamp.el
@@ -60,7 +60,7 @@ If nil, timestamping is turned off."
Only considered when `erc-insert-timestamp-function' is set to
`erc-insert-timestamp-left-and-right'. Used for displaying date
stamps on their own line, between messages. ERC inserts this
-flavor of stamp as a separate \"psuedo message\", so a final
+flavor of stamp as a separate \"pseudo message\", so a final
newline isn't necessary. For compatibility, only additional
trailing newlines beyond the first become empty lines. For
example, the default value results in an empty line after the
@@ -69,7 +69,8 @@ followed immediately by the next message on the next line.
ERC
expects to display these stamps less frequently, so the
formatting specifiers should reflect that. To omit these stamps
entirely, use a different `erc-insert-timestamp-function', such
-as `erc-timestamp-format-right'."
+as `erc-timestamp-format-right'. Note that changing this value
+during an ERC session requires cycling `erc-stamp-mode'."
:type 'string)
(defcustom erc-timestamp-format-right nil
@@ -147,8 +148,9 @@ appropriate ERC buffer before the change will take effect."
"Format string to be used when `erc-echo-timestamps' is non-nil.
This string specifies the format of the timestamp being echoed in
the minibuffer."
- :type '(choice (const "Timestamped %A, %H:%M:%S")
- (const "%Y-%m-%d %H:%M:%S %Z")
+ :type '(choice (const :tag "Timestamped Monday, 15:04:05"
+ "Timestamped %A, %H:%M:%S")
+ (const :tag "2006-01-02 15:04:05 MST" "%F %T %Z")
string))
(defcustom erc-echo-timestamp-zone nil
@@ -187,12 +189,7 @@ from entering them and instead jump over them."
(remove-hook 'erc-send-modify-hook #'erc-add-timestamp)
(remove-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect)
(remove-hook 'erc--pre-clear-functions #'erc-stamp--reset-on-clear)
- (erc-with-all-buffers-of-server nil nil
- (erc-stamp--setup)
- (kill-local-variable 'erc-stamp--last-stamp)
- (kill-local-variable 'erc-timestamp-last-inserted)
- (kill-local-variable 'erc-timestamp-last-inserted-left)
- (kill-local-variable 'erc-timestamp-last-inserted-right))))
+ (erc-buffer-do #'erc-stamp--setup)))
(defvar erc-stamp--invisible-property nil
"Existing `invisible' property value and/or symbol `timestamp'.")
@@ -219,17 +216,25 @@ This becomes the message's `erc-ts' text property."
(erc-compat--current-lisp-time))
(cl-defmethod erc-stamp--current-time :around ()
- (or erc-stamp--current-time
- (and erc--msg-props (gethash 'erc-ts erc--msg-props))
- (cl-call-next-method)))
+ (or erc-stamp--current-time (cl-call-next-method)))
(defvar erc-stamp--skip nil
"Non-nil means inhibit `erc-add-timestamp' completely.")
(defvar erc-stamp--allow-unmanaged nil
- "Non-nil means `erc-add-timestamp' runs unconditionally.
-Escape hatch for third-parties using lower-level API functions,
-such as `erc-display-line', directly.")
+ "Non-nil means run `erc-add-timestamp' almost unconditionally.
+This is an unofficial escape hatch for code wanting to use
+lower-level message-insertion functions, like `erc-insert-line',
+directly. Third parties needing such functionality should
+petition for it via \\[erc-bug].")
+
+(defvar erc-stamp--permanent-cursor-sensor-functions nil
+ "Non-nil means add `cursor-sensor-functions' unconditionally.
+This is an unofficial escape hatch for code wanting the text
+property `cursor-sensor-functions' to always be present,
+regardless of the option `erc-echo-timestamps'. Third parties
+needing such pre-5.6 behavior to stick around should make that
+known via \\[erc-bug].")
(defun erc-add-timestamp ()
"Add timestamp and text-properties to message.
@@ -259,8 +264,8 @@ or `erc-send-modify-hook'."
(erc-away-time))
(funcall erc-insert-away-timestamp-function
(erc-format-timestamp ct erc-away-timestamp-format)))
- (when erc-stamp--allow-unmanaged
- (add-text-properties (point-min) (1- (point-max))
+ (when erc-stamp--permanent-cursor-sensor-functions
+ (add-text-properties (point-min) (max (point-min) (1- (point-max)))
;; It's important for the function to
;; be different on different entries (bug#22700).
(list 'cursor-sensor-functions
@@ -634,7 +639,11 @@ printed just after each line's text (no alignment)."
"Functions appended to send and modify hooks when inserting date stamp.")
(defvar-local erc-stamp--date-format-end nil
- "Substring index marking usable portion of date stamp format.")
+ "Tristate value indicating how and whether date stamps have been set up.
+A non-nil value means the buffer has been initialized to use date
+stamps. An integer marks the `substring' TO parameter for
+truncating `erc-timestamp-format-left' prior to rendering. A
+value of t means the option's value doesn't require trimming.")
(defun erc-stamp--propertize-left-date-stamp ()
(add-text-properties (point-min) (1- (point-max))
@@ -642,20 +651,19 @@ printed just after each line's text (no alignment)."
(erc--hide-message 'timestamp)
(run-hooks 'erc-stamp--insert-date-hook))
-;; A kludge to pass state from insert hook to nested insert hook.
-(defvar erc-stamp--current-datestamp-left nil)
-
(defun erc-stamp--format-date-stamp (ct)
"Format left date stamp with `erc-timestamp-format-left'."
(unless erc-stamp--date-format-end
;; Don't add text properties to the trailing newline.
(setq erc-stamp--date-format-end
- (if (string-suffix-p "\n" erc-timestamp-format-left) -1 0)))
+ (if (string-suffix-p "\n" erc-timestamp-format-left) -1 t)))
;; Ignore existing `invisible' prop value because date stamps should
;; never be hideable except via `timestamp'.
(let (erc-stamp--invisible-property)
- (erc-format-timestamp ct (substring erc-timestamp-format-left
- 0 erc-stamp--date-format-end))))
+ (erc-format-timestamp ct (if (numberp erc-stamp--date-format-end)
+ (substring erc-timestamp-format-left
+ 0 erc-stamp--date-format-end)
+ erc-timestamp-format-left))))
;; Calling `erc-display-message' from within a hook it's currently
;; running is roundabout, but it's a definite means of ensuring hooks
@@ -663,40 +671,77 @@ printed just after each line's text (no alignment)."
;; adjust invisibility props.
(defun erc-stamp--insert-date-stamp-as-phony-message (string)
(cl-assert (string-empty-p string))
- (setq string erc-stamp--current-datestamp-left)
- (cl-assert string)
+ (setq string erc-timestamp-last-inserted-left)
(let ((erc-stamp--skip t)
- (erc--msg-props (map-into `((erc-msg . datestamp)
- (erc-ts . ,(erc-stamp--current-time)))
- 'hash-table))
(erc-insert-modify-hook `(,@erc-insert-modify-hook
erc-stamp--propertize-left-date-stamp))
+ (erc--insert-line-function #'insert-before-markers)
;; Don't run hooks that aren't expecting a narrowed buffer.
(erc-insert-pre-hook nil)
(erc-insert-done-hook nil))
- (erc-display-message nil nil (current-buffer) string)
- (setq erc-timestamp-last-inserted-left string)))
+ (erc-display-message nil nil (current-buffer) string)))
(defun erc-stamp--lr-date-on-pre-modify (_)
- (when-let ((ct (erc-stamp--current-time))
+ (when-let (((not erc-stamp--skip))
+ (ct (erc-stamp--current-time))
(rendered (erc-stamp--format-date-stamp ct))
((not (string-equal rendered erc-timestamp-last-inserted-left)))
- (erc-stamp--current-datestamp-left rendered)
(erc-insert-timestamp-function
#'erc-stamp--insert-date-stamp-as-phony-message))
- (save-restriction
- (narrow-to-region (or erc--insert-marker erc-insert-marker)
- (or erc--insert-marker erc-insert-marker))
- (let (erc-timestamp-format erc-away-timestamp-format)
- (erc-add-timestamp)))))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (or erc--insert-marker erc-insert-marker)
+ (or erc--insert-marker erc-insert-marker))
+ ;; Ensure all hooks, like `erc-stamp--insert-date-hook', only
+ ;; see the let-bound value below during `erc-add-timestamp'.
+ (setq erc-timestamp-last-inserted-left nil)
+ (let* ((aligned (erc-stamp--time-as-day ct))
+ (erc-stamp--current-time aligned)
+ ;; Forget current `erc-cmd', etc.
+ (erc--msg-props (map-into `((erc-msg . datestamp))
+ 'hash-table))
+ (erc-timestamp-last-inserted-left rendered)
+ erc-timestamp-format erc-away-timestamp-format)
+ ;; FIXME delete once convinced adjustment correct.
+ (cl-assert (string= rendered
+ (erc-stamp--format-date-stamp aligned)))
+ (erc-add-timestamp))
+ (setq erc-timestamp-last-inserted-left rendered)))))
+
+;; This minor mode is just a placeholder and currently unhelpful for
+;; managing complexity. A useful version would leave a marker during
+;; post-modify hooks and then perform insertions (before markers)
+;; during "done" hooks. This would enable completely decoupling from
+;; and possibly deprecating `erc-insert-timestamp-left-and-right'.
+;; However, doing this would require expanding the internal API to
+;; include insertion and deletion handlers for twiddling and massaging
+;; text properties based on context immediately after modifying text
+;; earlier in a buffer (away from `erc-insert-marker'). Without such
+;; handlers, things like "merged" `fill-wrap' speakers and invisible
+;; messages may be damaged by buffer modifications.
+(define-minor-mode erc-stamp--date-mode
+ "Insert date stamps as standalone messages."
+ :interactive nil
+ (if erc-stamp--date-mode
+ (progn (add-hook 'erc-insert-pre-hook
+ #'erc-stamp--lr-date-on-pre-modify 10 t)
+ (add-hook 'erc-pre-send-functions
+ #'erc-stamp--lr-date-on-pre-modify 10 t))
+ (kill-local-variable 'erc-timestamp-last-inserted-left)
+ (remove-hook 'erc-insert-pre-hook
+ #'erc-stamp--lr-date-on-pre-modify t)
+ (remove-hook 'erc-pre-send-functions
+ #'erc-stamp--lr-date-on-pre-modify t)))
(defvar erc-stamp-prepend-date-stamps-p nil
"When non-nil, date stamps are not independent messages.
-Users should think twice about enabling this escape hatch. It
-will likely degraded the user experience by causing post-5.5
-features, like `fill-wrap', dynamic invisibility, etc., to
-malfunction. Basic support for the default configuration may
-expire earlier than normally expected.")
+This flag restores pre-5.6 behavior in which date stamps formed
+the leading portion of affected messages. Beware that enabling
+this degrades the user experience by causing 5.6+ features, like
+`fill-wrap', dynamic invisibility, etc., to malfunction. When
+non-nil, none of the newline twiddling mentioned in the doc
+string for `erc-timestamp-format-left' occurs. That is, ERC does
+not append or remove trailing newlines.")
(make-obsolete-variable 'erc-stamp-prepend-date-stamps-p
"unsupported legacy behavior" "30.1")
@@ -714,9 +759,16 @@ requirements related to `erc-legacy-invisible-bounds-p'.
Additionally, ensure every date stamp is identifiable as such so
that internal modules can easily distinguish between other
left-sided stamps and date stamps inserted by this function."
- (unless (or erc-stamp--date-format-end erc-stamp-prepend-date-stamps-p)
- (add-hook 'erc-insert-pre-hook #'erc-stamp--lr-date-on-pre-modify -95 t)
- (add-hook 'erc-send-pre-functions #'erc-stamp--lr-date-on-pre-modify -95 t)
+ (unless (or erc-stamp--date-format-end erc-stamp-prepend-date-stamps-p
+ (and (or (null erc-timestamp-format-left)
+ (string-empty-p ; compat
+ (string-trim erc-timestamp-format-left "\n")))
+ (always (erc-stamp--date-mode -1))
+ (setq erc-stamp-prepend-date-stamps-p t)))
+ (erc-stamp--date-mode +1)
+ ;; Hooks used by ^ are the preferred means of inserting date
+ ;; stamps. But they'll never see this inaugural message, so it
+ ;; must be handled specially.
(let ((erc--insert-marker (point-min-marker))
(end-marker (point-max-marker)))
(set-marker-insertion-type erc--insert-marker t)
@@ -730,7 +782,10 @@ left-sided stamps and date stamps inserted by this
function."
(if erc-timestamp-format-right
(erc-format-timestamp ct erc-timestamp-format-right)
string))))
- ;; Maybe insert legacy date stamp.
+ ;; We should arguably be ensuring a trailing newline on legacy
+ ;; "prepended" date stamps as well. However, since this is a
+ ;; compatibility oriented code path, and pre-5.6 did no such
+ ;; thing, better to punt.
(when-let ((erc-stamp-prepend-date-stamps-p)
(ts-left (erc-format-timestamp ct erc-timestamp-format-left))
((not (string= ts-left erc-timestamp-last-inserted-left))))
@@ -746,6 +801,19 @@ left-sided stamps and date stamps inserted by this
function."
;; for testing: (setq erc-timestamp-only-if-changed-flag nil)
(defvar erc-stamp--tz nil)
+;; Unfortunately, cursory measurements show that this function is 10x
+;; slower than `erc-format-timestamp', which is perhaps
+;; counterintuitive. Thus, we use the latter for our cache, and
+;; perform day alignments via this function only when needed.
+(defun erc-stamp--time-as-day (current-time)
+ "Discard hour, minute, and second info from timestamp CURRENT-TIME."
+ (let* ((current-time-list) ; flag
+ (decoded (decode-time current-time erc-stamp--tz)))
+ (setf (decoded-time-second decoded) 0
+ (decoded-time-minute decoded) 0
+ (decoded-time-hour decoded) 0)
+ (encode-time decoded))) ; may return an integer
+
(defun erc-format-timestamp (time format)
"Return TIME formatted as string according to FORMAT.
Return the empty string if FORMAT is nil."
@@ -778,16 +846,18 @@ Return the empty string if FORMAT is nil."
(cursor-intangible-mode -1)))
(if erc-echo-timestamps
(progn
- (dolist (hook '(erc-insert-post-hook erc-send-post-hook))
- (add-hook hook #'erc-stamp--add-csf-on-post-modify nil t))
- (erc--restore-initialize-priors erc-stamp-mode
- erc-stamp--csf-props-updated-p nil)
- (unless (or erc-stamp--allow-unmanaged erc-stamp--csf-props-updated-p)
- (setq erc-stamp--csf-props-updated-p t)
- (let ((erc--msg-props (map-into '((erc-ts . t)) 'hash-table)))
- (with-silent-modifications
- (erc--traverse-inserted (point-min) erc-insert-marker
- #'erc-stamp--add-csf-on-post-modify))))
+ (unless erc-stamp--permanent-cursor-sensor-functions
+ (dolist (hook '(erc-insert-post-hook erc-send-post-hook))
+ (add-hook hook #'erc-stamp--add-csf-on-post-modify nil t))
+ (erc--restore-initialize-priors erc-stamp-mode
+ erc-stamp--csf-props-updated-p nil)
+ (unless erc-stamp--csf-props-updated-p
+ (setq erc-stamp--csf-props-updated-p t)
+ (let ((erc--msg-props (map-into '((erc-ts . t)) 'hash-table)))
+ (with-silent-modifications
+ (erc--traverse-inserted
+ (point-min) erc-insert-marker
+ #'erc-stamp--add-csf-on-post-modify)))))
(cursor-sensor-mode +1) ; idempotent
(when (>= emacs-major-version 29)
(add-function :before-until (local 'clear-message-function)
@@ -816,8 +886,10 @@ Return the empty string if FORMAT is nil."
(let (erc-echo-timestamps erc-hide-timestamps erc-timestamp-intangible)
(erc-munge-invisibility-spec))
;; Undo local mods from `erc-insert-timestamp-left-and-right'.
- (remove-hook 'erc-insert-pre-hook #'erc-stamp--lr-date-on-pre-modify t)
- (remove-hook 'erc-send-pre-functions #'erc-stamp--lr-date-on-pre-modify t)
+ (erc-stamp--date-mode -1) ; kills `erc-timestamp-last-inserted-left'
+ (kill-local-variable 'erc-stamp--last-stamp)
+ (kill-local-variable 'erc-timestamp-last-inserted)
+ (kill-local-variable 'erc-timestamp-last-inserted-right)
(kill-local-variable 'erc-stamp--date-format-end)))
(defun erc-hide-timestamps ()
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 0471ee0bbb8..fd57cb9d6a0 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -3026,16 +3026,19 @@ stored value. Otherwise, return the stored value."
"Return the bounds of a message in an ERC buffer.
Return ONLY one side when the first arg is `end' or `beg'. With
POINT, search from POINT instead of `point'."
+ ;; TODO add edebug spec.
`(let* ((point ,(or point '(point)))
(at-start-p (get-text-property point 'erc-msg)))
(and-let*
- (,@(and (member only '(nil 'beg))
+ (,@(and (member only '(nil beg 'beg))
'((b (or (and at-start-p point)
(and-let*
((p (previous-single-property-change point
'erc-msg)))
- (if (= p (1- point)) p (1- p)))))))
- ,@(and (member only '(nil 'end))
+ (if (= p (1- point))
+ (if (get-text-property p 'erc-msg) p (1- p))
+ (1- p)))))))
+ ,@(and (member only '(nil end 'end))
'((e (1- (next-single-property-change
(if at-start-p (1+ point) point)
'erc-msg nil erc-insert-marker))))))
@@ -3080,6 +3083,9 @@ If END is a marker, possibly update its position."
(unless (eq end erc-insert-marker)
(set-marker end nil)))
+(defvar erc--insert-line-function nil
+ "When non-nil, an alterntive to `insert' for inserting messages.")
+
(defvar erc--insert-marker nil
"Internal override for `erc-insert-marker'.")
@@ -3131,7 +3137,9 @@ modification hooks)."
(save-restriction
(widen)
(goto-char insert-position)
- (insert string)
+ (if erc--insert-line-function
+ (funcall erc--insert-line-function string)
+ (insert string))
(erc--assert-input-bounds)
;; run insertion hook, with point at restored location
(save-restriction
diff --git a/lisp/icomplete.el b/lisp/icomplete.el
index e6fdd1f1836..f4c4feb7304 100644
--- a/lisp/icomplete.el
+++ b/lisp/icomplete.el
@@ -722,7 +722,8 @@ See `icomplete-mode' and `minibuffer-setup-hook'."
;; Check if still in the right buffer (bug#61308)
(or (window-minibuffer-p) completion-in-region--data)
(icomplete-simple-completing-p)) ;Shouldn't be necessary.
- (let ((saved-point (point)))
+ (let ((saved-point (point))
+ (completion-lazy-hilit t))
(save-excursion
(goto-char (icomplete--field-end))
;; Insert the match-status information:
@@ -901,7 +902,7 @@ by `group-function''s second \"transformation\" protocol."
'icomplete-selected-match 'append comp)
collect (concat prefix
(make-string (- max-prefix-len (length prefix)) ? )
- comp
+ (completion-lazy-hilit comp)
(make-string (- max-comp-len (length comp)) ? )
suffix)
into lines-aux
@@ -1067,7 +1068,8 @@ matches exist."
(if (< prospects-len prospects-max)
(push comp prospects)
(setq limit t)))
- (setq prospects (nreverse prospects))
+ (setq prospects
+ (nreverse (mapcar #'completion-lazy-hilit prospects)))
;; Decorate first of the prospects.
(when prospects
(let ((first (copy-sequence (pop prospects))))
diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index 78688d170cc..e30c69f2441 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -1057,8 +1057,8 @@ Returns an error if the server cannot be contacted."
(while data-continue
(with-current-buffer buffer
(progress-reporter-update pr (point))
- (setq sending-data (buffer-substring (line-beginning-position)
- (line-end-position)))
+ (setq sending-data (buffer-substring-no-properties
(line-beginning-position)
+
(line-end-position)))
(end-of-line 2)
(setq data-continue (not (eobp))))
(smtpmail-send-data-1 process sending-data))
diff --git a/lisp/man.el b/lisp/man.el
index 506d6060269..f18e2f50b7c 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -105,6 +105,13 @@ When this is non-nil, call the \"man\" program
synchronously
:group 'man
:version "30.1")
+(defcustom Man-support-remote-systems nil
+ "Whether to call the Un*x \"man\" program on remote systems.
+When this is non-nil, call the \"man\" program on the remote
+system determined by `default-directory'."
+ :type 'boolean
+ :version "30.1")
+
(defcustom Man-filter-list nil
"Manpage cleaning filter command phrases.
This variable contains a list of the following form:
@@ -531,8 +538,9 @@ Otherwise, the value is whatever the function
(define-button-type 'Man-xref-normal-file
'action (lambda (button)
- (let ((f (substitute-in-file-name
- (button-get button 'Man-target-string))))
+ (let ((f (concat (file-remote-p default-directory)
+ (substitute-in-file-name
+ (button-get button 'Man-target-string)))))
(if (file-exists-p f)
(if (file-readable-p f)
(view-file f)
@@ -545,6 +553,65 @@ Otherwise, the value is whatever the function
;; ======================================================================
;; utilities
+(defun Man-default-directory ()
+ "Return a default directory according to `Man-support-remote-systems'."
+ ;; Ensure that `default-directory' exists and is readable.
+ ;; We assume, that this function is always called inside the `man'
+ ;; command, so that we can check `current-prefix-arg' for reverting
+ ;; `Man-support-remote-systems'.
+ (let ((result default-directory)
+ (remote (if current-prefix-arg
+ (not Man-support-remote-systems)
+ Man-support-remote-systems)))
+
+ ;; Use a local directory if remote isn't possible.
+ (when (and (file-remote-p default-directory)
+ (not (and remote
+ ;; TODO:: Test that remote processes are supported.
+ )))
+ (setq result (expand-file-name "~/")))
+
+ ;; Check, whether the directory is accessible.
+ (if (file-accessible-directory-p result)
+ result
+ (expand-file-name (concat (file-remote-p result) "~/")))))
+
+(defun Man-shell-file-name ()
+ "Return a proper shell file name, respecting remote directories."
+ (or ; This works also in the local case.
+ (with-connection-local-variables shell-file-name)
+ "/bin/sh"))
+
+(defun Man-header-file-path ()
+ "Return the C header file search path that Man should use.
+Normally, this is the value of the user option `Man-header-file-path',
+but when the man page is formatted on a remote system (see
+`Man-support-remote-systems'), this function tries to figure out the
+list of directories where the remote system has the C header files."
+ (let ((remote-id (file-remote-p default-directory)))
+ (if (null remote-id)
+ ;; The local case.
+ Man-header-file-path
+ ;; The remote case. Use connection-local variables.
+ (mapcar
+ (lambda (elt) (concat remote-id elt))
+ (with-connection-local-variables
+ (or (and (local-variable-p 'Man-header-file-path (current-buffer))
+ Man-header-file-path)
+ (setq-connection-local
+ Man-header-file-path
+ (let ((arch (with-temp-buffer
+ (when (zerop (ignore-errors
+ (process-file "gcc" nil '(t nil) nil
+ "-print-multiarch")))
+ (goto-char (point-min))
+ (buffer-substring (point) (line-end-position)))))
+ (base '("/usr/include" "/usr/local/include")))
+ (if (zerop (length arch))
+ base
+ (append
+ base (list (expand-file-name arch "/usr/include"))))))))))))
+
(defun Man-init-defvars ()
"Used for initializing variables based on display's color support.
This is necessary if one wants to dump man.el with Emacs."
@@ -583,7 +650,9 @@ This is necessary if one wants to dump man.el with Emacs."
(if Man-sed-script
(concat "-e '" Man-sed-script "'")
"")
- "-e '/^[\001-\032][\001-\032]*$/d'"
+ ;; Use octal numbers. Otherwise, \032 (Ctrl-Z) would
+ ;; suspend remote connections.
+ "-e '/^[\\o001-\\o032][\\o001-\\o032]*$/d'"
"-e '/\e[789]/s///g'"
"-e '/Reformatting page. Wait/d'"
"-e '/Reformatting entry. Wait/d'"
@@ -717,22 +786,23 @@ program has no such option, but interprets any name
containing
a \"/\" as a local filename. The function returns either `man-db'
`man', or nil."
(if (eq Man-support-local-filenames 'auto-detect)
- (setq Man-support-local-filenames
- (with-temp-buffer
- (let ((default-directory
- ;; Ensure that `default-directory' exists and is
readable.
- (if (file-accessible-directory-p default-directory)
- default-directory
- (expand-file-name "~/"))))
- (ignore-errors
- (call-process manual-program nil t nil "--help")))
- (cond ((search-backward "--local-file" nil 'move)
- 'man-db)
- ;; This feature seems to be present in at least ver 1.4f,
- ;; which is about 20 years old.
- ;; I don't know if this version has an official name?
- ((looking-at "^man, versione? [1-9]")
- 'man))))
+ (with-connection-local-variables
+ (or (and (local-variable-p 'Man-support-local-filenames
(current-buffer))
+ Man-support-local-filenames)
+ (setq-connection-local
+ Man-support-local-filenames
+ (with-temp-buffer
+ (let ((default-directory (Man-default-directory)))
+ (ignore-errors
+ (process-file manual-program nil t nil "--help")))
+ (cond ((search-backward "--local-file" nil 'move)
+ 'man-db)
+ ;; This feature seems to be present in at least
+ ;; ver 1.4f, which is about 20 years old. I
+ ;; don't know if this version has an official
+ ;; name?
+ ((looking-at "^man, versione? [1-9]")
+ 'man))))))
Man-support-local-filenames))
@@ -918,7 +988,8 @@ foo(sec)[, bar(sec) [, ...]] [other stuff] - description"
(unless (and Man-completion-cache
(string-prefix-p (car Man-completion-cache) prefix))
(with-temp-buffer
- (setq default-directory "/") ;; in case inherited doesn't exist
+ ;; In case inherited doesn't exist.
+ (setq default-directory (Man-default-directory))
;; Actually for my `man' the arg is a regexp.
;; POSIX says it must be ERE and "man-db" seems to agree,
;; whereas under macOS it seems to be BRE-style and doesn't
@@ -932,7 +1003,7 @@ foo(sec)[, bar(sec) [, ...]] [other stuff] - description"
;; error later.
(when (eq 0
(ignore-errors
- (call-process
+ (process-file
manual-program nil '(t nil) nil
"-k" (concat (when (or Man-man-k-use-anchor
(string-equal prefix ""))
@@ -1016,7 +1087,12 @@ names or descriptions. The pattern argument is usually
an
Note that in some cases you will need to use \\[quoted-insert] to quote the
SPC character in the above examples, because this command attempts
-to auto-complete your input based on the installed manual pages."
+to auto-complete your input based on the installed manual pages.
+
+If `default-directory' is remote, and `Man-support-remote-systems'
+is non-nil, this command formats the man page on the remote system.
+A prefix argument reverses the value of `Man-support-remote-systems'
+for the current invocation."
(interactive
(list (let* ((default-entry (Man-default-man-entry))
@@ -1082,12 +1158,7 @@ to auto-complete your input based on the installed
manual pages."
Man-coding-system
locale-coding-system))
;; Avoid possible error by using a directory that always exists.
- (default-directory
- (if (and (file-directory-p default-directory)
- (not (find-file-name-handler default-directory
- 'file-directory-p)))
- default-directory
- "/")))
+ (default-directory (Man-default-directory)))
;; Prevent any attempt to use display terminal fanciness.
(setenv "TERM" "dumb")
;; In Debian Woody, at least, we get overlong lines under X
@@ -1116,9 +1187,13 @@ to auto-complete your input based on the installed
manual pages."
(defun Man-getpage-in-background (topic)
"Use TOPIC to build and fire off the manpage and cleaning command.
Return the buffer in which the manpage will appear."
- (let* ((man-args topic)
- (bufname (concat "*Man " man-args "*"))
- (buffer (get-buffer bufname)))
+ (let* ((default-directory (Man-default-directory))
+ (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)))
+ (buffer (get-buffer bufname)))
(if buffer
(Man-notify-when-ready buffer)
(message "Invoking %s %s in the background" manual-program man-args)
@@ -1137,20 +1212,19 @@ Return the buffer in which the manpage will appear."
(Man-start-calling
(if (and (fboundp 'make-process)
(not Man-prefer-synchronous-call))
- (let ((proc (start-process
+ (let ((proc (start-file-process
manual-program buffer
- (if (memq system-type '(cygwin windows-nt))
- shell-file-name
- "sh")
+ (Man-shell-file-name)
shell-command-switch
(format (Man-build-man-command) man-args))))
(set-process-sentinel proc 'Man-bgproc-sentinel)
(set-process-filter proc 'Man-bgproc-filter))
(let* ((inhibit-read-only t)
(exit-status
- (call-process shell-file-name nil (list buffer nil) nil
- shell-command-switch
- (format (Man-build-man-command) man-args)))
+ (process-file
+ (Man-shell-file-name) nil (list buffer nil) nil
+ shell-command-switch
+ (format (Man-build-man-command) man-args)))
(msg ""))
(or (and (numberp exit-status)
(= exit-status 0))
@@ -1178,9 +1252,10 @@ Return the buffer in which the manpage will appear."
(buffer-read-only nil))
(erase-buffer)
(Man-start-calling
- (call-process shell-file-name nil (list (current-buffer) nil) nil
- shell-command-switch
- (format (Man-build-man-command) Man-arguments)))
+ (process-file
+ (Man-shell-file-name) nil (list (current-buffer) nil) nil
+ shell-command-switch
+ (format (Man-build-man-command) Man-arguments)))
(if Man-fontify-manpage-flag
(Man-fontify-manpage)
(Man-cleanup-manpage))
@@ -1944,7 +2019,7 @@ Specify which REFERENCE to use; default is based on word
at point."
;; Header file support
(defun Man-view-header-file (file)
"View a header file specified by FILE from `Man-header-file-path'."
- (let ((path Man-header-file-path)
+ (let ((path (Man-header-file-path))
complete-path)
(while path
(setq complete-path (expand-file-name file (car path))
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index b4e6eaa88b1..caf54d40fc2 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -679,6 +679,10 @@ for use at QPOS."
'completions-common-part)
qprefix))))
(qcompletion (concat qprefix qnew)))
+ ;; Attach unquoted completion string, which is needed
+ ;; to score the completion in `completion--flex-score'.
+ (put-text-property 0 1 'completion--unquoted
+ completion qcompletion)
;; FIXME: Similarly here, Cygwin's mapping trips this
;; assertion.
;;(cl-assert
@@ -1236,6 +1240,7 @@ Only the elements of table that satisfy predicate PRED
are considered.
POINT is the position of point within STRING.
The return value is a list of completions and may contain the base-size
in the last `cdr'."
+ (setq completion-lazy-hilit-fn nil)
;; FIXME: We need to additionally return the info needed for the
;; second part of completion-base-position.
(completion--nth-completion 2 string table pred point metadata))
@@ -1558,11 +1563,12 @@ scroll the window of possible completions."
(t (prog1 (pcase (completion--do-completion beg end)
(#b000 nil)
(_ t))
- (when (and (eq completion-auto-select t)
- (window-live-p minibuffer-scroll-window)
- (eq t (frame-visible-p (window-frame
minibuffer-scroll-window))))
- ;; When the completion list window was displayed, select it.
- (switch-to-completions))))))
+ (if (window-live-p minibuffer-scroll-window)
+ (and (eq completion-auto-select t)
+ (eq t (frame-visible-p (window-frame
minibuffer-scroll-window)))
+ ;; When the completion list window was displayed, select it.
+ (switch-to-completions))
+ (completion-in-region-mode -1))))))
(defun completion--cache-all-sorted-completions (beg end comps)
(add-hook 'after-change-functions
@@ -2709,8 +2715,14 @@ Also respects the obsolete wrapper hook
`completion-in-region-functions'.
completion-in-region-mode-predicate)
(setq-local minibuffer-completion-auto-choose nil)
(add-hook 'post-command-hook #'completion-in-region--postch)
- (push `(completion-in-region-mode . ,completion-in-region-mode-map)
- minor-mode-overriding-map-alist)))
+ (let* ((keymap completion-in-region-mode-map)
+ (keymap (if minibuffer-visible-completions
+ (make-composed-keymap
+ (list minibuffer-visible-completions-map
+ keymap))
+ keymap)))
+ (push `(completion-in-region-mode . ,keymap)
+ minor-mode-overriding-map-alist))))
;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it
;; on minor-mode-overriding-map-alist instead.
@@ -2955,8 +2967,46 @@ the mode hook of this mode."
:interactive nil
;; Enable text conversion, but always make sure `RET' does
;; something.
- (setq text-conversion-style 'action))
+ (setq text-conversion-style 'action)
+ (when minibuffer-visible-completions
+ (setq-local minibuffer-completion-auto-choose nil)))
+
+(defcustom minibuffer-visible-completions nil
+ "When non-nil, visible completions can be navigated from the minibuffer.
+This means that when the *Completions* buffer is visible in a window,
+then you can use the arrow keys in the minibuffer to move the cursor
+in the *Completions* buffer. Then you can type `RET',
+and the candidate highlighted in the *Completions* buffer
+will be accepted.
+But when the *Completions* buffer is not displayed on the screen,
+then the arrow keys move point in the minibuffer as usual, and
+`RET' accepts the input typed in the minibuffer."
+ :type 'boolean
+ :version "30.1")
+
+(defun minibuffer-visible-completions-bind (binding)
+ "Use BINDING when completions are visible.
+Return an item that is enabled only when a window
+displaying the *Completions* buffer exists."
+ `(menu-item
+ "" ,binding
+ :filter ,(lambda (cmd)
+ (when-let ((window (get-buffer-window "*Completions*" 0)))
+ (when (eq (buffer-local-value 'completion-reference-buffer
+ (window-buffer window))
+ (window-buffer (active-minibuffer-window)))
+ cmd)))))
+
+(defvar-keymap minibuffer-visible-completions-map
+ :doc "Local keymap for minibuffer input with visible completions."
+ "<left>" (minibuffer-visible-completions-bind
#'minibuffer-previous-completion)
+ "<right>" (minibuffer-visible-completions-bind #'minibuffer-next-completion)
+ "<up>" (minibuffer-visible-completions-bind
#'minibuffer-previous-line-completion)
+ "<down>" (minibuffer-visible-completions-bind
#'minibuffer-next-line-completion)
+ "RET" (minibuffer-visible-completions-bind
#'minibuffer-choose-completion-or-exit)
+ "C-g" (minibuffer-visible-completions-bind
#'minibuffer-hide-completions))
+
;;; Completion tables.
(defun minibuffer--double-dollars (str)
@@ -3751,108 +3801,191 @@ one large \"hole\" and a clumped-together \"oo\"
match) higher
than the latter (which has two \"holes\" and three
one-letter-long matches).")
+(defvar completion-lazy-hilit nil
+ "If non-nil, request lazy highlighting of completion candidates.
+
+Lisp programs (a.k.a. \"front ends\") that present completion
+candidates may opt to bind this variable to a non-nil value when
+calling functions (such as `completion-all-completions') which
+produce completion candidates. This tells the underlying
+completion styles that they do not need to fontify (i.e.,
+propertize with the `face' property) completion candidates in a
+way that highlights the matching parts. Then it is the front end
+which presents the candidates that becomes responsible for this
+fontification. The front end does that by calling the function
+`completion-lazy-hilit' on each completion candidate that is to be
+displayed to the user.
+
+Note that only some completion styles take advantage of this
+variable for optimization purposes. Other styles will ignore the
+hint and fontify eagerly as usual. It is still safe for a
+front end to call `completion-lazy-hilit' in these situations.
+
+To author a completion style that takes advantage of this variable,
+see `completion-lazy-hilit-fn' and `completion-pcm--hilit-commonality'.")
+
+(defvar completion-lazy-hilit-fn nil
+ "Fontification function set by lazy-highlighting completions styles.
+When a given style wants to enable support for `completion-lazy-hilit'
+\(which see), that style should set this variable to a function of one
+argument. It will be called with each completion candidate, a string, to
+be displayed to the user, and should destructively propertize these
+strings with the `face' property.")
+
+(defun completion-lazy-hilit (str)
+ "Return a copy of completion candidate STR that is `face'-propertized.
+See documentation of the variable `completion-lazy-hilit' for more
+details."
+ (if (and completion-lazy-hilit completion-lazy-hilit-fn)
+ (funcall completion-lazy-hilit-fn (copy-sequence str))
+ str))
+
+(defun completion--hilit-from-re (string regexp)
+ "Fontify STRING with `completions-common-part' using REGEXP."
+ (let* ((md (and regexp (string-match regexp string) (cddr (match-data t))))
+ (me (and md (match-end 0)))
+ (from 0))
+ (while md
+ (add-face-text-property from (pop md) 'completions-common-part nil
string)
+ (setq from (pop md)))
+ (unless (or (not me) (= from me))
+ (add-face-text-property from me 'completions-common-part nil string))
+ string))
+
+(defun completion--flex-score-1 (md-groups match-end len)
+ "Compute matching score of completion.
+The score lies in the range between 0 and 1, where 1 corresponds to
+the full match.
+MD-GROUPS is the \"group\" part of the match data.
+MATCH-END is the end of the match.
+LEN is the length of the completion string."
+ (let* ((from 0)
+ ;; To understand how this works, consider these simple
+ ;; ascii diagrams showing how the pattern "foo"
+ ;; flex-matches "fabrobazo", "fbarbazoo" and
+ ;; "barfoobaz":
+
+ ;; f abr o baz o
+ ;; + --- + --- +
+
+ ;; f barbaz oo
+ ;; + ------ ++
+
+ ;; bar foo baz
+ ;; +++
+
+ ;; "+" indicates parts where the pattern matched. A
+ ;; "hole" in the middle of the string is indicated by
+ ;; "-". Note that there are no "holes" near the edges
+ ;; of the string. The completion score is a number
+ ;; bound by (0..1] (i.e., larger than (but not equal
+ ;; to) zero, and smaller or equal to one): the higher
+ ;; the better and only a perfect match (pattern equals
+ ;; string) will have score 1. The formula takes the
+ ;; form of a quotient. For the numerator, we use the
+ ;; number of +, i.e. the length of the pattern. For
+ ;; the denominator, it first computes
+ ;;
+ ;; hole_i_contrib = 1 + (Li-1)^(1/tightness)
+ ;;
+ ;; , for each hole "i" of length "Li", where tightness
+ ;; is given by `flex-score-match-tightness'. The
+ ;; final value for the denominator is then given by:
+ ;;
+ ;; (SUM_across_i(hole_i_contrib) + 1) * len
+ ;;
+ ;; , where "len" is the string's length.
+ (score-numerator 0)
+ (score-denominator 0)
+ (last-b 0))
+ (while (and md-groups (car md-groups))
+ (let ((a from)
+ (b (pop md-groups)))
+ (setq
+ score-numerator (+ score-numerator (- b a)))
+ (unless (or (= a last-b)
+ (zerop last-b)
+ (= a len))
+ (setq
+ score-denominator (+ score-denominator
+ 1
+ (expt (- a last-b 1)
+ (/ 1.0
+ flex-score-match-tightness)))))
+ (setq
+ last-b b))
+ (setq from (pop md-groups)))
+ ;; If `pattern' doesn't have an explicit trailing any, the
+ ;; regex `re' won't produce match data representing the
+ ;; region after the match. We need to account to account
+ ;; for that extra bit of match (bug#42149).
+ (unless (= from match-end)
+ (let ((a from)
+ (b match-end))
+ (setq
+ score-numerator (+ score-numerator (- b a)))
+ (unless (or (= a last-b)
+ (zerop last-b)
+ (= a len))
+ (setq
+ score-denominator (+ score-denominator
+ 1
+ (expt (- a last-b 1)
+ (/ 1.0
+ flex-score-match-tightness)))))
+ (setq
+ last-b b)))
+ (/ score-numerator (* len (1+ score-denominator)) 1.0)))
+
+(defvar completion--flex-score-last-md nil
+ "Helper variable for `completion--flex-score'.")
+
+(defun completion--flex-score (str re &optional dont-error)
+ "Compute flex score of completion STR based on RE.
+If DONT-ERROR, just return nil if RE doesn't match STR."
+ (cond ((string-match re str)
+ (let* ((match-end (match-end 0))
+ (md (cddr
+ (setq
+ completion--flex-score-last-md
+ (match-data t completion--flex-score-last-md)))))
+ (completion--flex-score-1 md match-end (length str))))
+ ((not dont-error)
+ (error "Internal error: %s does not match %s" re str))))
+
+(defvar completion-pcm--regexp nil
+ "Regexp from PCM pattern in `completion-pcm--hilit-commonality'.")
+
(defun completion-pcm--hilit-commonality (pattern completions)
"Show where and how well PATTERN matches COMPLETIONS.
PATTERN, a list of symbols and strings as seen
`completion-pcm--merge-completions', is assumed to match every
-string in COMPLETIONS. Return a deep copy of COMPLETIONS where
-each string is propertized with `completion-score', a number
-between 0 and 1, and with faces `completions-common-part',
-`completions-first-difference' in the relevant segments."
+string in COMPLETIONS.
+
+If `completion-lazy-hilit' is nil, return a deep copy of
+COMPLETIONS where each string is propertized with
+`completion-score', a number between 0 and 1, and with faces
+`completions-common-part', `completions-first-difference' in the
+relevant segments.
+
+Else, if `completion-lazy-hilit' is t, return COMPLETIONS
+unchanged, but setup a suitable `completion-lazy-hilit-fn' (which
+see) for later lazy highlighting."
+ (setq completion-pcm--regexp nil
+ completion-lazy-hilit-fn nil)
(cond
((and completions (cl-loop for e in pattern thereis (stringp e)))
- (let* ((re (completion-pcm--pattern->regex pattern 'group))
- (point-idx (completion-pcm--pattern-point-idx pattern))
- (case-fold-search completion-ignore-case)
- last-md)
- (mapcar
- (lambda (str)
- ;; Don't modify the string itself.
- (setq str (copy-sequence str))
- (unless (string-match re str)
- (error "Internal error: %s does not match %s" re str))
- (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0)))
- (match-end (match-end 0))
- (md (cddr (setq last-md (match-data t last-md))))
- (from 0)
- (end (length str))
- ;; To understand how this works, consider these simple
- ;; ascii diagrams showing how the pattern "foo"
- ;; flex-matches "fabrobazo", "fbarbazoo" and
- ;; "barfoobaz":
-
- ;; f abr o baz o
- ;; + --- + --- +
-
- ;; f barbaz oo
- ;; + ------ ++
-
- ;; bar foo baz
- ;; +++
-
- ;; "+" indicates parts where the pattern matched. A
- ;; "hole" in the middle of the string is indicated by
- ;; "-". Note that there are no "holes" near the edges
- ;; of the string. The completion score is a number
- ;; bound by (0..1] (i.e., larger than (but not equal
- ;; to) zero, and smaller or equal to one): the higher
- ;; the better and only a perfect match (pattern equals
- ;; string) will have score 1. The formula takes the
- ;; form of a quotient. For the numerator, we use the
- ;; number of +, i.e. the length of the pattern. For
- ;; the denominator, it first computes
- ;;
- ;; hole_i_contrib = 1 + (Li-1)^(1/tightness)
- ;;
- ;; , for each hole "i" of length "Li", where tightness
- ;; is given by `flex-score-match-tightness'. The
- ;; final value for the denominator is then given by:
- ;;
- ;; (SUM_across_i(hole_i_contrib) + 1) * len
- ;;
- ;; , where "len" is the string's length.
- (score-numerator 0)
- (score-denominator 0)
- (last-b 0)
- (update-score-and-face
- (lambda (a b)
- "Update score and face given match range (A B)."
- (add-face-text-property a b
- 'completions-common-part
- nil str)
- (setq
- score-numerator (+ score-numerator (- b a)))
- (unless (or (= a last-b)
- (zerop last-b)
- (= a (length str)))
- (setq
- score-denominator (+ score-denominator
- 1
- (expt (- a last-b 1)
- (/ 1.0
-
flex-score-match-tightness)))))
- (setq
- last-b b))))
- (while md
- (funcall update-score-and-face from (pop md))
- (setq from (pop md)))
- ;; If `pattern' doesn't have an explicit trailing any, the
- ;; regex `re' won't produce match data representing the
- ;; region after the match. We need to account to account
- ;; for that extra bit of match (bug#42149).
- (unless (= from match-end)
- (funcall update-score-and-face from match-end))
- (if (> (length str) pos)
- (add-face-text-property
- pos (1+ pos)
- 'completions-first-difference
- nil str))
- (unless (zerop (length str))
- (put-text-property
- 0 1 'completion-score
- (/ score-numerator (* end (1+ score-denominator)) 1.0) str)))
- str)
- completions)))
+ (let* ((re (completion-pcm--pattern->regex pattern 'group)))
+ (setq completion-pcm--regexp re)
+ (cond (completion-lazy-hilit
+ (setq completion-lazy-hilit-fn
+ (lambda (str) (completion--hilit-from-re str re)))
+ completions)
+ (t
+ (mapcar
+ (lambda (str)
+ (completion--hilit-from-re (copy-sequence str) re))
+ completions)))))
(t completions)))
(defun completion-pcm--find-all-completions (string table pred point
@@ -4189,36 +4322,39 @@ that is non-nil."
(defun completion--flex-adjust-metadata (metadata)
"If `flex' is actually doing filtering, adjust sorting."
- (let ((flex-is-filtering-p
- ;; JT@2019-12-23: FIXME: this is kinda wrong. What we need
- ;; to test here is "some input that actually leads/led to
- ;; flex filtering", not "something after the minibuffer
- ;; prompt". E.g. The latter is always true for file
- ;; searches, meaning we'll be doing extra work when we
- ;; needn't.
- (or (not (window-minibuffer-p))
- (> (point-max) (minibuffer-prompt-end))))
+ (let ((flex-is-filtering-p completion-pcm--regexp)
(existing-dsf
(completion-metadata-get metadata 'display-sort-function))
(existing-csf
(completion-metadata-get metadata 'cycle-sort-function)))
(cl-flet
- ((compose-flex-sort-fn
- (existing-sort-fn) ; wish `cl-flet' had proper indentation...
- (lambda (completions)
- (sort
- (funcall existing-sort-fn completions)
- (lambda (c1 c2)
- (let ((s1 (get-text-property 0 'completion-score c1))
- (s2 (get-text-property 0 'completion-score c2)))
- (> (or s1 0) (or s2 0))))))))
+ ((compose-flex-sort-fn (existing-sort-fn)
+ (lambda (completions)
+ (let* ((sorted (sort
+ (mapcar
+ (lambda (str)
+ (cons
+ (- (completion--flex-score
+ (or (get-text-property
+ 0 'completion--unquoted str)
+ str)
+ completion-pcm--regexp))
+ str))
+ (if existing-sort-fn
+ (funcall existing-sort-fn completions)
+ completions))
+ #'car-less-than-car))
+ (cell sorted))
+ ;; Reuse the list
+ (while cell
+ (setcar cell (cdar cell))
+ (pop cell))
+ sorted))))
`(metadata
,@(and flex-is-filtering-p
- `((display-sort-function
- . ,(compose-flex-sort-fn (or existing-dsf #'identity)))))
+ `((display-sort-function . ,(compose-flex-sort-fn
existing-dsf))))
,@(and flex-is-filtering-p
- `((cycle-sort-function
- . ,(compose-flex-sort-fn (or existing-csf #'identity)))))
+ `((cycle-sort-function . ,(compose-flex-sort-fn existing-csf))))
,@(cdr metadata)))))
(defun completion-flex--make-flex-pattern (pattern)
@@ -4372,6 +4508,11 @@ See `completing-read' for the meaning of the arguments."
;; in minibuffer-local-filename-completion-map can
;; override bindings in base-keymap.
base-keymap)))
+ (keymap (if minibuffer-visible-completions
+ (make-composed-keymap
+ (list minibuffer-visible-completions-map
+ keymap))
+ keymap))
(buffer (current-buffer))
(c-i-c completion-ignore-case)
(result
@@ -4491,16 +4632,21 @@ selected by these commands to the minibuffer."
:type 'boolean
:version "29.1")
-(defun minibuffer-next-completion (&optional n)
+(defun minibuffer-next-completion (&optional n vertical)
"Move to the next item in its completions window from the minibuffer.
+When the optional argument VERTICAL is non-nil, move vertically
+to the next item on the next line using `next-line-completion'.
+Otherwise, move to the next item horizontally using `next-completion'.
When `minibuffer-completion-auto-choose' is non-nil, then also
-insert the selected completion to the minibuffer."
+insert the selected completion candidate to the minibuffer."
(interactive "p")
(let ((auto-choose minibuffer-completion-auto-choose))
(with-minibuffer-completions-window
(when completions-highlight-face
(setq-local cursor-face-highlight-nonselected-window t))
- (next-completion (or n 1))
+ (if vertical
+ (next-line-completion (or n 1))
+ (next-completion (or n 1)))
(when auto-choose
(let ((completion-use-base-affixes t))
(choose-completion nil t t))))))
@@ -4508,23 +4654,51 @@ insert the selected completion to the minibuffer."
(defun minibuffer-previous-completion (&optional n)
"Move to the previous item in its completions window from the minibuffer.
When `minibuffer-completion-auto-choose' is non-nil, then also
-insert the selected completion to the minibuffer."
+insert the selected completion candidate to the minibuffer."
(interactive "p")
(minibuffer-next-completion (- (or n 1))))
+(defun minibuffer-next-line-completion (&optional n)
+ "Move to the next completion line from the minibuffer.
+This means to move to the completion candidate on the next line
+in the *Completions* buffer while point stays in the minibuffer.
+When `minibuffer-completion-auto-choose' is non-nil, then also
+insert the selected completion candidate to the minibuffer."
+ (interactive "p")
+ (minibuffer-next-completion (or n 1) t))
+
+(defun minibuffer-previous-line-completion (&optional n)
+ "Move to the previous completion line from the minibuffer.
+This means to move to the completion candidate on the previous line
+in the *Completions* buffer while point stays in the minibuffer.
+When `minibuffer-completion-auto-choose' is non-nil, then also
+insert the selected completion candidate to the minibuffer."
+ (interactive "p")
+ (minibuffer-next-completion (- (or n 1)) t))
+
(defun minibuffer-choose-completion (&optional no-exit no-quit)
"Run `choose-completion' from the minibuffer in its completions window.
-With prefix argument NO-EXIT, insert the completion at point to the
-minibuffer, but don't exit the minibuffer. When the prefix argument
+With prefix argument NO-EXIT, insert the completion candidate at point to
+the minibuffer, but don't exit the minibuffer. When the prefix argument
is not provided, then whether to exit the minibuffer depends on the value
of `completion-no-auto-exit'.
-If NO-QUIT is non-nil, insert the completion at point to the
+If NO-QUIT is non-nil, insert the completion candidate at point to the
minibuffer, but don't quit the completions window."
(interactive "P")
- (with-minibuffer-completions-window
+ (with-minibuffer-completions-window
(let ((completion-use-base-affixes t))
(choose-completion nil no-exit no-quit))))
+(defun minibuffer-choose-completion-or-exit (&optional no-exit no-quit)
+ "Choose the completion from the minibuffer or exit the minibuffer.
+When `minibuffer-choose-completion' can't find a completion candidate
+in the completions window, then exit the minibuffer using its present
+contents."
+ (interactive "P")
+ (condition-case nil
+ (minibuffer-choose-completion no-exit no-quit)
+ (error (minibuffer-complete-and-exit))))
+
(defun minibuffer-complete-history ()
"Complete the minibuffer history as far as possible.
Like `minibuffer-complete' but completes on the history items
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index dfb2243988d..74740af3bd6 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -1337,7 +1337,7 @@ point."
(setq url (browse-url-encode-url url)))
;; Make sure the URL starts with an appropriate scheme.
(unless (string-match "\\(.+\\):/" url)
- (setq url (concat "http://"; url)))
+ (setq url (concat browse-url-default-scheme "://" url)))
(android-browse-url url browse-url-android-share))
(function-put 'browse-url-default-android-browser
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index e43ef2bfe8b..d8a66b2ce32 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -100,7 +100,7 @@ no parameters) that returns a directory name."
Each of the elements is a function returning either a string or a list
of strings. The results will be joined into a single list with
duplicate entries (if any) removed."
- :version "27.1"
+ :version "30.1"
:group 'eww
:type 'hook
:options '(eww-links-at-point
diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
index 274cca7123a..09f7ac52537 100644
--- a/lisp/net/nsm.el
+++ b/lisp/net/nsm.el
@@ -550,14 +550,14 @@ Due to its use of 64-bit block size, it is known that a
ciphertext collision is highly likely when 2^32 blocks are
encrypted with the same key bundle under 3-key 3DES. Practical
birthday attacks of this kind have been demonstrated by Sweet32[1].
-As such, NIST is in the process of disallowing its use in TLS[2].
+As such, NIST has disallowed its use after December 31, 2023[2].
[1]: Bhargavan, Leurent (2016). \"On the Practical (In-)Security of
64-bit Block Ciphers — Collision Attacks on HTTP over TLS and
OpenVPN\", `https://sweet32.info/'
-[2]: NIST Information Technology Laboratory (Jul 2017). \"Update to
-Current Use and Deprecation of TDEA\",
-`https://csrc.nist.gov/News/2017/Update-to-Current-Use-and-Deprecation-of-TDEA'"
+[2]: National Institute of Standards and Technology (Mar 2019).
+\"Transitioning the Use of Cryptographic Algorithms and Key
+Lengths\", `https://doi.org/10.6028/NIST.SP.800-131Ar2'"
(let ((cipher (plist-get status :cipher)))
(and (string-match "\\b3DES\\b" cipher)
(format-message
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index 1a2ad15f5b2..5b3395b77d2 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -2710,7 +2710,7 @@ PRESTART is the position basing on which START was found."
(defun cperl-beginning-of-property (p prop &optional lim)
"Given that P has a property PROP, find where the property starts.
Will not look before LIM."
-;;; XXXX What to do at point-max???
+;; XXXX What to do at point-max???
(or (previous-single-property-change (cperl-1+ p) prop lim)
(point-min))
;; (cond ((eq p (point-min))
@@ -3061,7 +3061,7 @@ and closing parentheses and brackets."
(error nil))
(current-column))
((eq 'indentable (elt i 0)) ; Indenter for REGEXP qw() etc
- (cond ;;; [indentable terminator start-pos is-block]
+ (cond ; [indentable terminator start-pos is-block]
((eq 'terminator (elt i 1)) ; Lone terminator of "indentable string"
(goto-char (elt i 2)) ; After opening parens
(1- (current-column)))
@@ -3948,8 +3948,6 @@ recursive calls in starting lines of here-documents."
"\\|"
;; Second variant: Identifier or \ID (same as 'ID')
"\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\)" ; 5 + 1, 6 + 1
- ;; Do not have <<= or << 30 or <<30 or << $blah.
- ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
"\\)"
"\\|"
;; -------- format capture groups 8-9
@@ -4137,20 +4135,10 @@ recursive calls in starting lines of here-documents."
;; Here document
;; We can do many here-per-line;
;; but multiline quote on the same line as <<HERE confuses us...
- ;; ;; One extra () before this:
- ;;"<<"
+ ;; One extra () before this:
;; "<<\\(~?\\)" ; HERE-DOC, indented-p = capture 2
- ;; ;; First variant "BLAH" or just ``.
- ;; "[ \t]*" ; Yes, whitespace is allowed!
- ;; "\\([\"'`]\\)" ; 3 + 1
- ;; "\\([^\"'`\n]*\\)" ; 4 + 1
- ;; "\\4"
- ;; "\\|"
- ;; ;; Second variant: Identifier or \ID or empty
- ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 5 + 1, 6 + 1
- ;; ;; Do not have <<= or << 30 or <<30 or << $blah.
- ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1
- ;; "\\)"
+ ;; First variant "BLAH" or just ``: capture groups 4 and 5
+ ;; Second variant: Identifier or \ID: capture group 6 and 7
((match-beginning 3) ; 2 + 1: found "<<", detect its type
(let* ((matched-pos (match-beginning 0))
(quoted-delim-p (if (match-beginning 6) nil t))
@@ -4169,10 +4157,8 @@ recursive calls in starting lines of here-documents."
overshoot (nth 1 here-doc-results))
(and (nth 2 here-doc-results)
(setq warning-message (nth 2 here-doc-results)))))))
- ;; format
+ ;; format capture groups 8-9
((match-beginning 8)
- ;; 1+6=7 extra () before this:
- ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
(setq b (point)
name (if (match-beginning 9) ; 7 + 2
(match-string-no-properties 9) ; 7 + 2
@@ -4219,12 +4205,9 @@ recursive calls in starting lines of here-documents."
(if (> (point) max)
(setq tmpend tb))
(put-text-property b (point) 'syntax-type 'format))
- ;; qq-like String or Regexp:
+ ;; quotelike operator or regexp: capture groups 10 or 11
+ ;; matches some false postives, to be eliminated here
((or (match-beginning 10) (match-beginning 11))
- ;; 1+6+2=9 extra () before this:
- ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"
- ;; "\\|"
- ;; "\\([/<]\\)" ; /blah/ or <file*glob>
(setq b1 (if (match-beginning 10) 10 11)
argument (buffer-substring
(match-beginning b1) (match-end b1))
@@ -4281,13 +4264,23 @@ recursive calls in starting lines of here-documents."
(and (eq (char-syntax (preceding-char)) ?w)
(progn
(forward-sexp -1)
-;; After these keywords `/' starts a RE. One should add all the
-;; functions/builtins which expect an argument, but ...
+ ;; After these keywords `/'
+ ;; starts a RE. One should
+ ;; add all the
+ ;; functions/builtins which
+ ;; expect an argument, but
+ ;; ...
(and
(not (memq (preceding-char)
'(?$ ?@ ?& ?%)))
(looking-at
-
"\\(while\\|if\\|unless\\|until\\|for\\(each\\)?\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\|return\\)\\>"))))
+ (regexp-opt
+ '("while" "if" "unless"
+ "until" "for" "foreach"
+ "and" "or" "not"
+ "xor" "split" "grep" "map"
+ "print" "say" "return")
+ 'symbols)))))
(and (eq (preceding-char) ?.)
(eq (char-after (- (point) 2)) ?.))
(bobp))
@@ -4487,12 +4480,13 @@ recursive calls in starting lines of here-documents."
(1- e) e 'face my-cperl-delimiters-face)))
(if (and is-REx cperl-regexp-scan)
;; Process RExen: embedded comments, charclasses and ]
-;;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{ foo })/;
-;;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/;
-;;;/(?<=foo)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx;
-;;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/;
-;;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] + m)(^ab[c]$|.+\));
-;;;m^a[\^b]c^ + m.a[^b]\.c.;
+ ;; Examples:
+ ;;/\3333\xFg\x{FFF}a\ppp\PPP\qqq\C\99f(?{ foo })(??{
foo })/;
+
;;/a\.b[^a[:ff:]b]x$ab->$[|$,$ab->[cd]->[ef]|$ab[xy].|^${a,b}{c,d}/;
+
;;/(?<=foo)(?<!bar)(x)(?:$ab|\$\/)$|\\\b\x888\776\[\:$/xxx;
+ ;;m?(\?\?{b,a})? + m/(??{aa})(?(?=xx)aa|bb)(?#aac)/;
+ ;;m$(^ab[c]\$)$ + m+(^ab[c]\$\+)+ + m](^ab[c\]$|.+)] +
m)(^ab[c]$|.+\));
+ ;;m^a[\^b]c^ + m.a[^b]\.c.;
(save-excursion
(goto-char (1+ b))
;; First
@@ -4556,8 +4550,6 @@ recursive calls in starting lines of here-documents."
"\\?([0-9]+)" ; (?(1)foo|bar)
"\\|"
"\\?<[=!]"
- ;;;"\\|"
- ;;; "\\?"
"\\)?"
"\\)"
"\\|"
@@ -4702,8 +4694,8 @@ recursive calls in starting lines of here-documents."
(setq REx-subgr-end qtag) ;End smart-highlighted
;; Apparently, I can't put \] into a charclass
;; in m]]: m][\\\]\]] produces [\\]]
-;;; POSIX? [:word:] [:^word:] only inside []
-;;; "\\=\\(\\\\.\\|[^][\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
+ ;; POSIX? [:word:] [:^word:] only inside []
+ ;;
"\\=\\(\\\\.\\|[^][\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]")
(while ; look for unescaped ]
(and argument
(re-search-forward
@@ -4891,7 +4883,6 @@ recursive calls in starting lines of here-documents."
;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'")
((match-beginning 19) ; old $abc'efg syntax
(setq bb (match-end 0))
- ;;;(if (nth 3 state) nil ; in string
(put-text-property (1- bb) bb 'syntax-table cperl-st-word)
(goto-char bb))
;; 1+6+2+1+1+6+1+1=19 extra () before this:
@@ -4908,7 +4899,7 @@ recursive calls in starting lines of here-documents."
(setq bb (match-end 0))
(goto-char b)
(skip-chars-backward "\\\\")
- ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1))
+ ;; (setq i2 (= (% (skip-chars-backward "\\\\") 2) -1))
(cperl-modify-syntax-type b cperl-st-punct)
(goto-char bb))
(t (error "Error in regexp of the sniffer")))
@@ -6053,9 +6044,9 @@ functions (which they are not). Inherits from
`default'.")
(group (eval cperl--basic-identifier-rx))))
1 font-lock-constant-face)
;; Uncomment to get perl-mode-like vars
- ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face)
- ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)"
- ;;; (2 (cons font-lock-variable-name-face '(underline))))
+ ;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face)
+ ;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)"
+ ;; (2 (cons font-lock-variable-name-face '(underline))))
;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var
;; -------- variable declarations
;; (matcher (subexp facespec) ...
@@ -6196,13 +6187,13 @@ functions (which they are not). Inherits from
`default'.")
(,(rx (group-n 1 (group-n 2 (or (in "@%") "$#"))
(eval cperl--normal-identifier-rx)))
1
-;; ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
+ ;; ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
(if (eq (char-after (match-beginning 2)) ?%)
'cperl-hash-face
'cperl-array-face)
nil)
-;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
-;;; Too much noise from \s* @s[ and friends
+ ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
+ ;; Too much noise from \s* @s[ and friends
;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^
\t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
;;(3 font-lock-function-name-face t t)
;;(4
@@ -8929,7 +8920,8 @@ do extra unwind via `cperl-unwind-to-safe'."
(defun cperl-fontify-update-bad (end)
;; Since fontification happens with different region than syntaxification,
- ;; do to the end of buffer, not to END;;; likewise, start earlier if needed
+ ;; do to the end of buffer, not to END
+ ;; likewise, start earlier if needed
(let* ((pos (point)) (prop (get-text-property pos 'cperl-postpone)) posend)
(if prop
(setq pos (or (cperl-beginning-of-property
diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el
index eba66503bf7..816f6952d2e 100644
--- a/lisp/progmodes/eglot.el
+++ b/lisp/progmodes/eglot.el
@@ -1366,7 +1366,18 @@ INTERACTIVE is t if called interactively."
;;;###autoload
(defun eglot-ensure ()
- "Start Eglot session for current buffer if there isn't one."
+ "Start Eglot session for current buffer if there isn't one.
+
+Only use this function (in major mode hooks, etc) if you are
+confident that Eglot can be started safely and efficiently for
+*every* buffer visited where these hooks may execute.
+
+Since it is difficult to establish this confidence fully, it's
+often wise to use the interactive command `eglot' instead. This
+command only needs to be invoked once per project, as all other
+files of a given major mode visited within the same project will
+automatically become managed with no further user intervention
+needed."
(let ((buffer (current-buffer)))
(cl-labels
((maybe-connect
@@ -1374,7 +1385,9 @@ INTERACTIVE is t if called interactively."
(eglot--when-live-buffer buffer
(remove-hook 'post-command-hook #'maybe-connect t)
(unless eglot--managed-mode
- (apply #'eglot--connect (eglot--guess-contact))))))
+ (condition-case-unless-debug oops
+ (apply #'eglot--connect (eglot--guess-contact))
+ (error (eglot--warn (error-message-string oops))))))))
(when buffer-file-name
(add-hook 'post-command-hook #'maybe-connect 'append t)))))
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index ff90a744ea3..63198a660be 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -456,7 +456,7 @@ use of `macroexpand-all' as a way to find the \"underlying
raw code\".")
(lambda (expander form &rest args)
(condition-case err
(apply expander form args)
- ((debug error)
+ (error
(message "Ignoring macroexpansion error: %S" err) form))))
(sexp
(unwind-protect
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 6fd714940b6..5a669fdbd42 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -672,15 +672,6 @@ This variable is like `sgml-attribute-offset'."
:type 'integer
:safe 'integerp)
-;;; Keymap
-
-(defvar-keymap js-mode-map
- :doc "Keymap for `js-mode'."
- "M-." #'js-find-symbol)
-
-(defvar js-ts-mode-map (copy-keymap js-mode-map)
- "Keymap used in `js-ts-mode'.")
-
;;; Syntax table and parsing
(defvar js-mode-syntax-table
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index bb44cfefa54..95db9d0ef4c 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -245,7 +245,12 @@ of the project instance object."
pr))
(defun project--find-in-directory (dir)
- (run-hook-with-args-until-success 'project-find-functions dir))
+ ;; Use 'ignore-error' when 27.1 is the minimum supported.
+ (condition-case nil
+ (run-hook-with-args-until-success 'project-find-functions dir)
+ ;; Maybe we'd like to continue to the next backend instead? Let's
+ ;; see if somebody ever ends up in that situation.
+ (permission-denied nil)))
(defvar project--within-roots-fallback nil)
@@ -850,6 +855,7 @@ DIRS must contain directory names."
(define-key map "G" 'project-or-external-find-regexp)
(define-key map "r" 'project-query-replace-regexp)
(define-key map "x" 'project-execute-extended-command)
+ (define-key map "o" 'project-any-command)
(define-key map "\C-b" 'project-list-buffers)
map)
"Keymap for project commands.")
@@ -1812,6 +1818,46 @@ It's also possible to enter an arbitrary directory not
in the list."
(let ((default-directory (project-root (project-current t))))
(call-interactively #'execute-extended-command)))
+;;;###autoload
+(defun project-any-command (&optional overriding-map prompt-format)
+ "Run the next command in the current project.
+If the command is in `project-prefix-map', it gets passed that
+info with `project-current-directory-override'. Otherwise,
+`default-directory' is temporarily set to the current project's
+root.
+
+If OVERRIDING-MAP is non-nil, it will be used as
+`overriding-local-map' to provide shorter bindings from that map
+which will take priority over the global ones."
+ (interactive)
+ (let* ((pr (project-current t))
+ (prompt-format (or prompt-format "[execute in %s]:"))
+ (command (let ((overriding-local-map overriding-map))
+ (key-binding (read-key-sequence
+ (format prompt-format (project-root pr)))
+ t)))
+ (root (project-root pr))
+ found)
+ (when command
+ ;; We could also check the command name against "\\`project-",
+ ;; and/or (get command 'project-command).
+ (map-keymap
+ (lambda (_evt cmd) (if (eq cmd command) (setq found t)))
+ project-prefix-map)
+ (if found
+ (let ((project-current-directory-override root))
+ (call-interactively command))
+ (let ((default-directory root))
+ (call-interactively command))))))
+
+;;;###autoload
+(defun project-prefix-or-any-command ()
+ "Run the next command in the current project.
+Works like `project-any-command', but also mixes in the shorter
+bindings from `project-prefix-map'."
+ (interactive)
+ (project-any-command project-prefix-map "[execute in %s]:"))
+
(defun project-remember-projects-under (dir &optional recursive)
"Index all projects below a directory DIR.
If RECURSIVE is non-nil, recurse into all subdirectories to find
@@ -1820,35 +1866,28 @@ the progress. The function returns the number of
detected
projects."
(interactive "DDirectory: \nP")
(project--ensure-read-project-list)
- (let ((queue (list dir))
- (count 0)
- (known (make-hash-table
- :size (* 2 (length project--list))
- :test #'equal )))
+ (let ((dirs (if recursive
+ (directory-files-recursively dir "" t)
+ (directory-files dir t)))
+ (known (make-hash-table :size (* 2 (length project--list))
+ :test #'equal))
+ (count 0))
(dolist (project (mapcar #'car project--list))
(puthash project t known))
- (while queue
- (when-let ((subdir (pop queue))
- ((file-directory-p subdir)))
- (when-let ((project (project--find-in-directory subdir))
- (project-root (project-root project))
- ((not (gethash project-root known))))
- (project-remember-project project t)
- (puthash project-root t known)
- (message "Found %s..." project-root)
- (setq count (1+ count)))
- (when (and recursive (file-directory-p subdir))
- (setq queue
- (nconc
- (directory-files
- subdir t directory-files-no-dot-files-regexp t)
- queue)))))
- (unless (eq recursive 'in-progress)
- (if (zerop count)
- (message "No projects were found")
- (project--write-project-list)
- (message "%d project%s were found"
- count (if (= count 1) "" "s"))))
+ (dolist (subdir dirs)
+ (when-let (((file-directory-p subdir))
+ (project (project--find-in-directory subdir))
+ (project-root (project-root project))
+ ((not (gethash project-root known))))
+ (project-remember-project project t)
+ (puthash project-root t known)
+ (message "Found %s..." project-root)
+ (setq count (1+ count))))
+ (if (zerop count)
+ (message "No projects were found")
+ (project--write-project-list)
+ (message "%d project%s were found"
+ count (if (= count 1) "" "s")))
count))
(defun project-forget-zombie-projects ()
@@ -1890,7 +1929,8 @@ forgotten projects."
(project-find-regexp "Find regexp")
(project-find-dir "Find directory")
(project-vc-dir "VC-Dir")
- (project-eshell "Eshell"))
+ (project-eshell "Eshell")
+ (project-any-command "Other"))
"Alist mapping commands to descriptions.
Used by `project-switch-project' to construct a dispatch menu of
commands available upon \"switching\" to another project.
@@ -1914,7 +1954,9 @@ invoked immediately without any dispatch menu."
(choice :tag "Key to press"
(const :tag "Infer from the keymap" nil)
(character :tag "Explicit key"))))
- (symbol :tag "Single command")))
+ (const :tag "Use both short keys and global bindings"
+ project-prefix-or-any-command)
+ (symbol :tag "Custom command")))
(defcustom project-switch-use-entire-map nil
"Whether `project-switch-project' will use the entire `project-prefix-map'.
@@ -2024,9 +2066,14 @@ to directory DIR."
(interactive (list (funcall project-prompter)))
(let ((command (if (symbolp project-switch-commands)
project-switch-commands
- (project--switch-project-command))))
- (let ((project-current-directory-override dir))
- (call-interactively command))))
+ (project--switch-project-command)))
+ (buffer (current-buffer)))
+ (unwind-protect
+ (progn
+ (setq-local project-current-directory-override dir)
+ (call-interactively command))
+ (with-current-buffer buffer
+ (kill-local-variable 'project-current-directory-override)))))
;;;###autoload
(defun project-uniquify-dirname-transform (dirname)
@@ -2058,7 +2105,7 @@ is part of the default mode line beginning with Emacs 30."
:version "30.1")
(defvar project-menu-entry
- `(menu-item "Project" ,menu-bar-project-menu))
+ `(menu-item "Project" ,(bound-and-true-p menu-bar-project-menu)))
(defvar project-mode-line-map
(let ((map (make-sparse-keymap)))
@@ -2074,14 +2121,21 @@ is part of the default mode line beginning with Emacs
30."
(defun project-mode-line-format ()
"Compose the project mode-line."
(when-let ((project (project-current)))
- (concat
- " "
- (propertize
- (project-name project)
- 'face project-mode-line-face
- 'mouse-face 'mode-line-highlight
- 'help-echo "mouse-1: Project menu"
- 'local-map project-mode-line-map))))
+ ;; Preserve the global value of 'last-coding-system-used'
+ ;; that 'write-region' needs to set for 'basic-save-buffer',
+ ;; but updating the mode line might occur at the same time
+ ;; during saving the buffer and 'project-name' can change
+ ;; 'last-coding-system-used' when reading the project name
+ ;; from .dir-locals.el also enables flyspell-mode (bug#66825).
+ (let ((last-coding-system-used last-coding-system-used))
+ (concat
+ " "
+ (propertize
+ (project-name project)
+ 'face project-mode-line-face
+ 'mouse-face 'mode-line-highlight
+ 'help-echo "mouse-1: Project menu"
+ 'local-map project-mode-line-map)))))
(provide 'project)
;;; project.el ends here
diff --git a/lisp/progmodes/ruby-ts-mode.el b/lisp/progmodes/ruby-ts-mode.el
index fabe5859779..4f85e1c63ff 100644
--- a/lisp/progmodes/ruby-ts-mode.el
+++ b/lisp/progmodes/ruby-ts-mode.el
@@ -25,7 +25,7 @@
;;; Commentary:
;; This file defines ruby-ts-mode which is a major mode for editing
-;; Ruby files that uses Tree Sitter to parse the language. More
+;; Ruby files that uses Tree Sitter to parse the language. More
;; information about Tree Sitter can be found in the ELisp Info pages
;; as well as this website: https://tree-sitter.github.io/tree-sitter/
@@ -1198,7 +1198,7 @@ leading double colon is not added."
(syntax-ppss-flush-cache (cl-loop for r in ranges
minimize (car r))))))
-(if (treesit-ready-p 'ruby)
+(if (treesit-ready-p 'ruby t)
;; Copied from ruby-mode.el.
(add-to-list 'auto-mode-alist
(cons (concat "\\(?:\\.\\(?:"
diff --git a/lisp/saveplace.el b/lisp/saveplace.el
index 590c55d2609..1330d00f10a 100644
--- a/lisp/saveplace.el
+++ b/lisp/saveplace.el
@@ -156,7 +156,9 @@ either `setopt' or M-x customize-variable to set this
option."
:set (lambda (sym val)
(set-default sym val)
(or save-place-loaded (save-place-load-alist-from-file))
- (let ((fun (if val #'abbreviate-file-name #'expand-file-name)))
+ (let ((fun (if val #'abbreviate-file-name #'expand-file-name))
+ ;; Don't expand file names for non-existing remote connections.
+ (non-essential t))
(setq save-place-alist
(cl-delete-duplicates
(cl-loop for (k . v) in save-place-alist
diff --git a/lisp/simple.el b/lisp/simple.el
index 6cbf8767ef8..0d399ba5c94 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -9821,6 +9821,8 @@ makes it easier to edit it."
(define-key map "\C-m" 'choose-completion)
(define-key map "\e\e\e" 'delete-completion-window)
(define-key map [remap keyboard-quit] #'delete-completion-window)
+ (define-key map [up] 'previous-line-completion)
+ (define-key map [down] 'next-line-completion)
(define-key map [left] 'previous-completion)
(define-key map [right] 'next-completion)
(define-key map [?\t] 'next-completion)
@@ -9882,8 +9884,9 @@ Go to the window from which completion was requested."
(select-window (get-buffer-window buf))))))
(defcustom completion-auto-wrap t
- "Non-nil means to wrap around when selecting completion options.
-This affects the commands `next-completion' and `previous-completion'.
+ "Non-nil means to wrap around when selecting completion candidates.
+This affects the commands `next-completion', `previous-completion',
+`next-line-completion' and `previous-line-completion'.
When `completion-auto-select' is t, it wraps through the minibuffer
for the commands bound to the TAB key."
:type 'boolean
@@ -9891,12 +9894,12 @@ for the commands bound to the TAB key."
:group 'completion)
(defcustom completion-auto-select nil
- "Non-nil means to automatically select the *Completions* buffer.
+ "If non-nil, automatically select the window showing the *Completions*
buffer.
When the value is t, pressing TAB will switch to the completion list
buffer when Emacs pops up a window showing that buffer.
If the value is `second-tab', then the first TAB will pop up the
window showing the completions list buffer, and the next TAB will
-switch to that window.
+select that window.
See `completion-auto-help' for controlling when the window showing
the completions is popped up and down."
:type '(choice (const :tag "Don't auto-select completions window" nil)
@@ -9907,7 +9910,7 @@ the completions is popped up and down."
:group 'completion)
(defun first-completion ()
- "Move to the first item in the completion list."
+ "Move to the first item in the completions buffer."
(interactive)
(goto-char (point-min))
(if (get-text-property (point) 'mouse-face)
@@ -9919,7 +9922,7 @@ the completions is popped up and down."
(goto-char pos))))
(defun last-completion ()
- "Move to the last item in the completion list."
+ "Move to the last item in the completions buffer."
(interactive)
(goto-char (previous-single-property-change
(point-max) 'mouse-face nil (point-min)))
@@ -9929,7 +9932,7 @@ the completions is popped up and down."
(goto-char pos))))
(defun previous-completion (n)
- "Move to the previous item in the completion list.
+ "Move to the previous item in the completions buffer.
With prefix argument N, move back N items (negative N means move
forward).
@@ -9938,7 +9941,7 @@ Also see the `completion-auto-wrap' variable."
(next-completion (- n)))
(defun next-completion (n)
- "Move to the next item in the completion list.
+ "Move to the next item in the completions buffer.
With prefix argument N, move N items (negative N means move
backward).
@@ -10001,6 +10004,93 @@ Also see the `completion-auto-wrap' variable."
(when (/= 0 n)
(switch-to-minibuffer))))
+(defun previous-line-completion (&optional n)
+ "Move to completion candidate on the previous line in the completions buffer.
+With prefix argument N, move back N lines (negative N means move forward).
+
+Also see the `completion-auto-wrap' variable."
+ (interactive "p")
+ (next-line-completion (- n)))
+
+(defun next-line-completion (&optional n)
+ "Move to completion candidate on the next line in the completions buffer.
+With prefix argument N, move N lines forward (negative N means move backward).
+
+Also see the `completion-auto-wrap' variable."
+ (interactive "p")
+ (let (line column pos found)
+ (when (and (bobp)
+ (> n 0)
+ (get-text-property (point) 'mouse-face)
+ (not (get-text-property (point) 'first-completion)))
+ (let ((inhibit-read-only t))
+ (add-text-properties (point) (1+ (point)) '(first-completion t)))
+ (setq n (1- n)))
+
+ (if (get-text-property (point) 'mouse-face)
+ ;; If in a completion, move to the start of it.
+ (when (and (not (bobp))
+ (get-text-property (1- (point)) 'mouse-face))
+ (goto-char (previous-single-property-change (point) 'mouse-face)))
+ ;; Try to move to the previous completion.
+ (setq pos (previous-single-property-change (point) 'mouse-face))
+ (if pos
+ ;; Move to the start of the previous completion.
+ (progn
+ (goto-char pos)
+ (unless (get-text-property (point) 'mouse-face)
+ (goto-char (previous-single-property-change
+ (point) 'mouse-face nil (point-min)))))
+ (cond ((> n 0) (setq n (1- n)) (first-completion))
+ ((< n 0) (first-completion)))))
+
+ (while (> n 0)
+ (setq found nil pos nil column (current-column) line
(line-number-at-pos))
+ (while (and (not found)
+ (eq (forward-line 1) 0)
+ (not (eobp))
+ (eq (move-to-column column) column))
+ (when (get-text-property (point) 'mouse-face)
+ (setq found t)))
+ (when (not found)
+ (if (not completion-auto-wrap)
+ (last-completion)
+ (save-excursion
+ (goto-char (point-min))
+ (when (and (eq (move-to-column column) column)
+ (get-text-property (point) 'mouse-face))
+ (setq pos (point)))
+ (while (and (not pos) (> line (line-number-at-pos)))
+ (forward-line 1)
+ (when (and (eq (move-to-column column) column)
+ (get-text-property (point) 'mouse-face))
+ (setq pos (point)))))
+ (if pos (goto-char pos))))
+ (setq n (1- n)))
+
+ (while (< n 0)
+ (setq found nil pos nil column (current-column) line
(line-number-at-pos))
+ (while (and (not found)
+ (eq (forward-line -1) 0)
+ (eq (move-to-column column) column))
+ (when (get-text-property (point) 'mouse-face)
+ (setq found t)))
+ (when (not found)
+ (if (not completion-auto-wrap)
+ (first-completion)
+ (save-excursion
+ (goto-char (point-max))
+ (when (and (eq (move-to-column column) column)
+ (get-text-property (point) 'mouse-face))
+ (setq pos (point)))
+ (while (and (not pos) (< line (line-number-at-pos)))
+ (forward-line -1)
+ (when (and (eq (move-to-column column) column)
+ (get-text-property (point) 'mouse-face))
+ (setq pos (point)))))
+ (if pos (goto-char pos))))
+ (setq n (1+ n)))))
+
(defun choose-completion (&optional event no-exit no-quit)
"Choose the completion at point.
If EVENT, use EVENT's position to determine the starting position.
@@ -11088,7 +11178,12 @@ place. If undo information is being recorded, make
sure
`undo-auto-current-boundary-timer' will run within the next 5
seconds."
(interactive)
- (let ((any-nonephemeral nil))
+ ;; One important consideration to bear in mind when adjusting this
+ ;; code is to _never_ move point in reaction to an edit so long as
+ ;; the additional processing undertaken by this function does not
+ ;; also edit the buffer text.
+ (let ((any-nonephemeral nil)
+ point-moved)
;; The list must be processed in reverse.
(dolist (edit (reverse text-conversion-edits))
;; Filter out ephemeral edits and deletions after point. Here, we
@@ -11096,6 +11191,9 @@ seconds."
;; can be identified.
(when (stringp (nth 3 edit))
(with-current-buffer (car edit)
+ ;; Record that the point hasn't been moved by the execution
+ ;; of a post command or text conversion hook.
+ (setq point-moved nil)
(if (not (eq (nth 1 edit) (nth 2 edit)))
;; Process this insertion. (nth 3 edit) is the text which
;; was inserted.
@@ -11111,15 +11209,20 @@ seconds."
;; Save the current undo list to figure out
;; whether or not auto-fill has actually taken
;; place.
- (old-undo-list buffer-undo-list))
+ (old-undo-list buffer-undo-list)
+ ;; Save the point position to return it there
+ ;; later.
+ (old-point (point)))
(save-excursion
(if (and auto-fill-function newline-p)
(progn (goto-char (nth 2 edit))
(previous-logical-line)
- (funcall auto-fill-function))
+ (funcall auto-fill-function)
+ (setq old-point (point)))
(when (and auto-fill-function auto-fill-p)
- (progn (goto-char (nth 2 edit))
- (funcall auto-fill-function))))
+ (goto-char (nth 2 edit))
+ (funcall auto-fill-function)
+ (setq old-point (point))))
;; Record whether or not this edit should result in
;; an undo boundary being added.
(setq any-nonephemeral
@@ -11130,10 +11233,22 @@ seconds."
(not (eq old-undo-list
buffer-undo-list)))))
(goto-char (nth 2 edit))
- (let ((last-command-event end))
+ (let ((last-command-event end)
+ (point (point)))
(unless (run-hook-with-args-until-success
'post-text-conversion-hook)
- (run-hooks 'post-self-insert-hook))))
+ (run-hooks 'post-self-insert-hook))
+ (when (not (eq (point) point))
+ (setq point-moved t)))
+ ;; If post-self-insert-hook doesn't move the point,
+ ;; restore it to its previous location. Generally,
+ ;; the call to goto-char upon processing the last edit
+ ;; recorded text-conversion-edit will see to this, but
+ ;; if the input method sets point expressly, no edit
+ ;; will be recorded, and point will wind up away from
+ ;; where the input method believes it is.
+ (unless point-moved
+ (goto-char old-point)))
;; Process this deletion before point. (nth 2 edit) is the
;; text which was deleted. Input methods typically prefer
;; to edit words instead of deleting characters off their
diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el
index 960dfdcb4a6..7d9a033d723 100644
--- a/lisp/term/android-win.el
+++ b/lisp/term/android-win.el
@@ -75,19 +75,28 @@ DISPLAY is ignored on Android."
(defvar android-primary-selection nil
"The last string placed in the primary selection.
-Nil if there was no such string.
+nil if there was no such string.
-Android does not have a primary selection of its own, so Emacs
-emulates one inside Lisp.")
+Android is not equipped with a primary selection of its own, so
+Emacs emulates one in Lisp.")
+
+(defvar android-secondary-selection nil
+ "The last string placed in the secondary selection.
+nil if there was no such string.
+
+Android is not equipped with a secondary selection of its own, so
+Emacs emulates one in Lisp.")
(defun android-get-clipboard-1 (data-type)
- "Return the clipboard data.
-DATA-TYPE is a selection conversion target. `STRING' means to
-return the contents of the clipboard as a string. `TARGETS'
-means to return supported data types as a vector.
+ "Return data saved from the clipboard.
+DATA-TYPE is a selection conversion target.
+
+`STRING' means return the contents of the clipboard as a string,
+while `TARGETS' means return the types of all data present within
+the clipboard as a vector.
-Interpret any other symbol as a MIME type, and return its
-corresponding data."
+Interpret any other symbol as a MIME type for which any clipboard
+data is returned"
(or (and (eq data-type 'STRING)
(android-get-clipboard))
(and (eq data-type 'TARGETS)
@@ -95,7 +104,8 @@ corresponding data."
(vconcat [TARGETS STRING]
(let ((i nil))
(dolist (type (android-get-clipboard-targets))
- ;; Don't report plain text as a valid target.
+ ;; Don't report plain text as a valid target
+ ;; since it is addressed by STRING.
(unless (equal type "text/plain")
(push (intern type) i)))
(nreverse i))))
@@ -109,7 +119,16 @@ Return nil if DATA-TYPE is anything other than STRING or
TARGETS."
(or (and (eq data-type 'STRING)
android-primary-selection)
(and (eq data-type 'TARGETS)
- [TARGETS]))))
+ [TARGETS STRING]))))
+
+(defun android-get-secondary (data-type)
+ "Return the last string placed in the secondary selection, or nil.
+Return nil if DATA-TYPE is anything other than STRING or TARGETS."
+ (when android-secondary-selection
+ (or (and (eq data-type 'STRING)
+ android-secondary-selection)
+ (and (eq data-type 'TARGETS)
+ [TARGETS STRING]))))
(defun android-selection-bounds (value)
"Return bounds of selection value VALUE.
@@ -152,26 +171,34 @@ VALUE should be something suitable for passing to
(cond ((eq type 'CLIPBOARD)
(android-get-clipboard-1 data-type))
((eq type 'PRIMARY)
- (android-get-primary data-type))))
+ (android-get-primary data-type))
+ ((eq type 'SECONDARY)
+ (android-get-secondary data-type))))
(cl-defmethod gui-backend-selection-exists-p (selection
&context (window-system android))
(cond ((eq selection 'CLIPBOARD)
(android-clipboard-exists-p))
((eq selection 'PRIMARY)
- (not (null android-primary-selection)))))
+ (not (null android-primary-selection)))
+ ((eq selection 'SECONDARY)
+ (not (null android-secondary-selection)))))
(cl-defmethod gui-backend-selection-owner-p (selection
&context (window-system android))
(cond ((eq selection 'CLIPBOARD)
(let ((ownership (android-clipboard-owner-p)))
- ;; If ownership is `lambda', then Emacs couldn't determine
+ ;; If ownership is `lambda', then Emacs couldn't establish
;; whether or not it owns the clipboard.
(and (not (eq ownership 'lambda)) ownership)))
((eq selection 'PRIMARY)
;; Emacs always owns its own primary selection as long as it
;; exists.
- (not (null android-primary-selection)))))
+ (not (null android-primary-selection)))
+ ((eq selection 'SECONDARY)
+ ;; Emacs always owns its own secondary selection as long as
+ ;; it exists.
+ (not (null android-secondary-selection)))))
(cl-defmethod gui-backend-set-selection (type value
&context (window-system android))
@@ -181,7 +208,9 @@ VALUE should be something suitable for passing to
(cond ((eq type 'CLIPBOARD)
(android-set-clipboard string))
((eq type 'PRIMARY)
- (setq android-primary-selection string)))))
+ (setq android-primary-selection string))
+ ((eq type 'SECONDARY)
+ (setq android-secondary-selection string)))))
;;; Character composition display.
@@ -295,5 +324,20 @@ content:// URIs into the special file names which
represent them."
(define-key special-event-map [drag-n-drop] 'android-handle-dnd-event)
+;; Bind keys sent by input methods to manipulate the state of the
+;; selection to commands which set or deactivate the mark.
+
+(defun android-deactivate-mark-command ()
+ "Deactivate the mark in this buffer.
+This command is generally invoked by input methods sending
+the `stop-selecting-text' editing key."
+ (interactive)
+ (deactivate-mark))
+
+(global-set-key [select-all] 'mark-whole-buffer)
+(global-set-key [start-selecting-text] 'set-mark-command)
+(global-set-key [stop-selecting-text] 'android-deactivate-mark-command)
+
+
(provide 'android-win)
;; android-win.el ends here.
diff --git a/lisp/treesit.el b/lisp/treesit.el
index 3555396390d..45c5f313a8e 100644
--- a/lisp/treesit.el
+++ b/lisp/treesit.el
@@ -439,6 +439,41 @@ unlike in their original functions."
(treesit-node-prev-sibling node named)))))))
node)
+(defun treesit-node-enclosed-p (smaller larger &optional strict)
+ "Return non-nil if SMALLER is enclosed in LARGER.
+SMALLER and LARGER can be either (BEG . END) or a node.
+
+Return non-nil if LARGER's start <= SMALLER's start and LARGER's
+end <= SMALLER's end.
+
+If STRICT is t, compare with < rather than <=.
+
+If STRICT is \\='partial, consider LARGER encloses SMALLER when
+at least one side is strictly enclosing."
+ (unless (and (or (consp larger) (treesit-node-p larger))
+ (or (consp smaller) (treesit-node-p smaller)))
+ (signal 'wrong-type-argument '((or cons treesit-node))))
+ (let ((larger-start (if (consp larger)
+ (car larger)
+ (treesit-node-start larger)))
+ (larger-end (if (consp larger)
+ (cdr larger)
+ (treesit-node-end larger)))
+ (smaller-start (if (consp smaller)
+ (car smaller)
+ (treesit-node-start smaller)))
+ (smaller-end (if (consp smaller)
+ (cdr smaller)
+ (treesit-node-end smaller))))
+ (pcase strict
+ ('t (and (< larger-start smaller-start)
+ (< smaller-end larger-end)))
+ ('partial (and (or (not (eq larger-start smaller-start))
+ (not (eq larger-end smaller-end)))
+ (<= larger-start smaller-start
+ smaller-end larger-end)))
+ (_ (<= larger-start smaller-start smaller-end larger-end)))))
+
;;; Query API supplement
(defun treesit-query-string (string query language)
@@ -2026,7 +2061,7 @@ return nil without moving point."
;; the obstacle, like `forward-sexp' does. If we couldn't
;; find a parent, we simply return nil without moving point,
;; then functions like `up-list' will signal "at top level".
- (when-let* ((parent (nth 2 (treesit--things-around (point) pred)))
+ (when-let* ((parent (treesit--thing-at (point) pred t))
(boundary (if (> arg 0)
(treesit-node-child parent -1)
(treesit-node-child parent 0))))
@@ -2080,7 +2115,8 @@ friends."
;; - treesit-thing/defun-at-point
;;
;; And more generic functions like:
-;; - treesit--things-around
+;; - treesit--thing-prev/next
+;; - treesit--thing-at
;; - treesit--top-level-thing
;; - treesit--navigate-thing
;;
@@ -2089,11 +2125,13 @@ friends."
;;
;; TODO: I'm not entirely sure how would this go, so I only documented
;; the "defun" functions and didn't document any "thing" functions.
-;; We should also document `treesit-block-type-regexp' and support it
-;; in major modes if we can meaningfully integrate hideshow: I tried
-;; and failed, we need SomeOne that understands hideshow to look at
-;; it. (BTW, hideshow should use its own
-;; `treesit-hideshow-block-type-regexp'.)
+;; We should also document `treesit-thing-settings'.
+
+;; TODO: Integration with thing-at-point: once our thing interface is
+;; stable.
+;;
+;; TODO: Integration with hideshow: I tried and failed, we need
+;; SomeOne that understands hideshow to look at it.
(defvar-local treesit-defun-type-regexp nil
"A regexp that matches the node type of defun nodes.
@@ -2321,17 +2359,7 @@ the current line if the beginning of the defun is
indented."
(line-beginning-position))
(beginning-of-line))))
-;; prev-sibling:
-;; 1. end-of-node before pos
-;; 2. highest such node
-;;
-;; next-sibling:
-;; 1. beg-of-node after pos
-;; 2. highest such node
-;;
-;; parent:
-;; 1. node covers pos
-;; 2. smallest such node
+(make-obsolete 'treesit--things-around "`treesit--things-around' will be
removed in a few months, use `treesit--thing-prev', `treesit--thing-next',
`treesit--thing-at' instead." "30.0.5")
(defun treesit--things-around (pos thing)
"Return the previous, next, and parent thing around POS.
@@ -2392,6 +2420,77 @@ which see; it can also be a predicate."
(treesit-parent-until cursor iter-pred)))
result))
+(defun treesit--thing-sibling (pos thing prev)
+ "Return the next or previous THING at POS.
+
+If PREV is non-nil, return the previous THING. It's guaranteed
+that returned previous sibling's end <= POS, and returned next
+sibling's beginning >= POS.
+
+Return nil if no THING can be found. THING should be a thing
+defined in `treesit-thing-settings', or a predicate as described
+in `treesit-thing-settings'."
+ (let* ((cursor (treesit-node-at pos))
+ (pos-pred (if prev
+ (lambda (n) (<= (treesit-node-end n) pos))
+ (lambda (n) (>= (treesit-node-start n) pos))))
+ (iter-pred (lambda (node)
+ (and (treesit-node-match-p node thing t)
+ (funcall pos-pred node))))
+ (sibling nil))
+ (when cursor
+ ;; Find the node just before/after POS to start searching.
+ (save-excursion
+ (while (and cursor (not (funcall pos-pred cursor)))
+ (setq cursor (treesit-search-forward-goto
+ cursor "" prev prev t))))
+ ;; Keep searching until we run out of candidates or found a
+ ;; return value.
+ (while (and cursor
+ (funcall pos-pred cursor)
+ (null sibling))
+ (setq sibling (treesit-node-top-level cursor iter-pred t))
+ (setq cursor (treesit-search-forward cursor thing prev prev)))
+ sibling)))
+
+(defun treesit--thing-prev (pos thing)
+ "Return the previous THING at POS.
+
+The returned node, if non-nil, must be before POS, i.e., its end
+<= POS.
+
+THING should be a thing defined in `treesit-thing-settings', or a
+predicate as described in `treesit-thing-settings'."
+ (treesit--thing-sibling pos thing t))
+
+(defun treesit--thing-next (pos thing)
+ "Return the next THING at POS.
+
+The returned node, if non-nil, must be after POS, i.e., its
+start >= POS.
+
+THING should be a thing defined in `treesit-thing-settings', or a
+predicate as described in `treesit-thing-settings'."
+ (treesit--thing-sibling pos thing nil))
+
+(defun treesit--thing-at (pos thing &optional strict)
+ "Return the smallest THING enclosing POS.
+
+The returned node, if non-nil, must enclose POS, i.e., its start
+<= POS, its end > POS. If STRICT is non-nil, the returned node's
+start must < POS rather than <= POS.
+
+THING should be a thing defined in `treesit-thing-settings', or
+it can be a predicate described in `treesit-thing-settings'."
+ (let* ((cursor (treesit-node-at pos))
+ (iter-pred (lambda (node)
+ (and (treesit-node-match-p node thing t)
+ (if strict
+ (< (treesit-node-start node) pos)
+ (<= (treesit-node-start node) pos))
+ (< pos (treesit-node-end node))))))
+ (treesit-parent-until cursor iter-pred t)))
+
;; The basic idea for nested defun navigation is that we first try to
;; move across sibling defuns in the same level, if no more siblings
;; exist, we move to parents's beg/end, rinse and repeat. We never
@@ -2458,9 +2557,15 @@ function is called recursively."
dest)))))
(catch 'term
(while (> counter 0)
- (pcase-let
- ((`(,prev ,next ,parent)
- (treesit--things-around pos thing)))
+ (let ((prev (treesit--thing-prev pos thing))
+ (next (treesit--thing-next pos thing))
+ (parent (treesit--thing-at pos thing t)))
+ (when (and parent prev
+ (not (treesit-node-enclosed-p prev parent)))
+ (setq prev nil))
+ (when (and parent next
+ (not (treesit-node-enclosed-p next parent)))
+ (setq next nil))
;; When PARENT is nil, nested and top-level are the same, if
;; there is a PARENT, make PARENT to be the top-level parent
;; and pretend there is no nested PREV and NEXT.
@@ -2521,22 +2626,15 @@ function is called recursively."
;; TODO: In corporate into thing-at-point.
(defun treesit-thing-at-point (thing tactic)
- "Return the thing node at point or nil if none is found.
-
-\"Thing\" is defined by THING, which can be a regexp, a
-predication function, and more, see `treesit-thing-settings'
-for details.
-
-Return the top-level defun if TACTIC is `top-level', return the
-immediate parent thing if TACTIC is `nested'."
- (pcase-let* ((`(,_ ,next ,parent)
- (treesit--things-around (point) thing))
- ;; If point is at the beginning of a thing, we
- ;; prioritize that thing over the parent in nested
- ;; mode.
- (node (or (and (eq (treesit-node-start next) (point))
- next)
- parent)))
+ "Return the THING at point or nil if none is found.
+
+THING can be a symbol, regexp, a predicate function, and more,
+see `treesit-thing-settings' for details.
+
+Return the top-level THING if TACTIC is `top-level', return the
+smallest enclosing THING as POS if TACTIC is `nested'."
+
+ (let ((node (treesit--thing-at (point) thing)))
(if (eq tactic 'top-level)
(treesit-node-top-level node thing t)
node)))
@@ -3523,7 +3621,6 @@ function signals an error."
(define-short-documentation-group treesit
-
"Parsers"
(treesit-parser-create
:no-eval (treesit-parser-create 'c)
@@ -3573,6 +3670,9 @@ function signals an error."
"Retrieving a node from another node"
+ (treesit-node-get
+ :no-eval (treesit-node-get node '((parent 1) (sibling 1) (text)))
+ :eg-result-string "#<treesit-node (declaration) in 1-11>")
(treesit-node-parent
:no-eval (treesit-node-parent node)
:eg-result-string "#<treesit-node (declaration) in 1-11>")
@@ -3666,7 +3766,9 @@ function signals an error."
(treesit-node-check
:no-eval (treesit-node-check node 'named)
:eg-result t)
-
+ (treesit-node-enclosed-p
+ :no-eval (treesit-node-enclosed-p node1 node2)
+ :no-eval (treesit-node-enclosed-p node1 '(12 . 18)))
(treesit-node-field-name-for-child
:no-eval (treesit-node-field-name-for-child node)
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 9ec45c59893..707fc7cfc07 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -1723,7 +1723,7 @@ This requires git 1.8.4 or later, for the \"-L\" option
of \"git log\"."
"^refs/\\(heads\\|tags\\|remotes\\)/\\(.*\\)$")))
(while (re-search-forward regexp nil t)
(push (match-string 2) table))))
- table))
+ (nreverse table)))
(defun vc-git-revision-completion-table (files)
(letrec ((table (lazy-completion-table
diff --git a/src/Makefile.in b/src/Makefile.in
index 0f16b485a3e..83f7ce4136f 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -944,6 +944,8 @@ elnlisp := \
international/charscript.eln \
emacs-lisp/comp.eln \
emacs-lisp/comp-cstr.eln \
+ emacs-lisp/comp-common.eln \
+ emacs-lisp/comp-run.eln \
international/emoji-zwj.eln
elnlisp := $(addprefix ${lispsource}/,${elnlisp}) $(lisp:.elc=.eln)
diff --git a/src/alloc.c b/src/alloc.c
index 0bd9ec4d706..38d04399716 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -6828,20 +6828,6 @@ mark_face_cache (struct face_cache *c)
}
}
-NO_INLINE /* To reduce stack depth in mark_object. */
-static void
-mark_localized_symbol (struct Lisp_Symbol *ptr)
-{
- struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
- Lisp_Object where = blv->where;
- /* If the value is set up for a killed buffer restore its global binding. */
- if ((BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where))))
- swap_in_global_binding (ptr);
- mark_object (blv->where);
- mark_object (blv->valcell);
- mark_object (blv->defcell);
-}
-
/* Remove killed buffers or items whose car is a killed buffer from
LIST, and mark other items. Return changed LIST, which is marked. */
@@ -7244,7 +7230,17 @@ process_mark_stack (ptrdiff_t base_sp)
break;
}
case SYMBOL_LOCALIZED:
- mark_localized_symbol (ptr);
+ {
+ struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
+ Lisp_Object where = blv->where;
+ /* If the value is set up for a killed buffer,
+ restore its global binding. */
+ if (BUFFERP (where) && !BUFFER_LIVE_P (XBUFFER (where)))
+ swap_in_global_binding (ptr);
+ mark_stack_push_value (blv->where);
+ mark_stack_push_value (blv->valcell);
+ mark_stack_push_value (blv->defcell);
+ }
break;
case SYMBOL_FORWARDED:
/* If the value is forwarded to a buffer or keyboard field,
diff --git a/src/android.c b/src/android.c
index 79f16568fd4..7a670cb507f 100644
--- a/src/android.c
+++ b/src/android.c
@@ -1938,6 +1938,45 @@ NATIVE_NAME (quit) (JNIEnv *env, jobject object)
kill (getpid (), SIGIO);
}
+/* Call shut_down_emacs subsequent to a call to the service's
+ onDestroy callback. CLOSURE is ignored. */
+
+static void
+android_shut_down_emacs (void *closure)
+{
+ __android_log_print (ANDROID_LOG_INFO, __func__,
+ "The Emacs service is being shut down");
+ shut_down_emacs (0, Qnil);
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (shutDownEmacs) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ android_run_in_emacs_thread (android_shut_down_emacs, NULL);
+}
+
+/* Carry out garbage collection and clear all image caches on the
+ Android terminal. Called when the system has depleted most of its
+ memory and desires that background processes release unused
+ core. */
+
+static void
+android_on_low_memory (void *closure)
+{
+ Fclear_image_cache (Qt, Qt);
+ garbage_collect ();
+}
+
+JNIEXPORT void JNICALL
+NATIVE_NAME (onLowMemory) (JNIEnv *env, jobject object)
+{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
+ android_run_in_emacs_thread (android_on_low_memory, NULL);
+}
+
JNIEXPORT jlong JNICALL
NATIVE_NAME (sendConfigureNotify) (JNIEnv *env, jobject object,
jshort window, jlong time,
@@ -5598,6 +5637,27 @@ android_get_keysym_name (int keysym, char *name_return,
size_t size)
const char *buffer;
jmethodID method;
+ /* These keysyms are special editor actions sent by the input
+ method. */
+
+ switch (keysym)
+ {
+ case 65536 + 1:
+ strncpy (name_return, "select-all", size - 1);
+ name_return[size] = '\0';
+ return;
+
+ case 65536 + 2:
+ strncpy (name_return, "start-selecting-text", size - 1);
+ name_return[size] = '\0';
+ return;
+
+ case 65536 + 3:
+ strncpy (name_return, "stop-selecting-text", size - 1);
+ name_return[size] = '\0';
+ return;
+ }
+
method = service_class.name_keysym;
string
= (*android_java_env)->CallNonvirtualObjectMethod (android_java_env,
@@ -5607,6 +5667,13 @@ android_get_keysym_name (int keysym, char *name_return,
size_t size)
(jint) keysym);
android_exception_check ();
+ if (!string)
+ {
+ strncpy (name_return, "stop-selecting-text", size - 1);
+ name_return[size] = '\0';
+ return;
+ }
+
buffer = (*android_java_env)->GetStringUTFChars (android_java_env,
(jstring) string,
NULL);
diff --git a/src/androidterm.c b/src/androidterm.c
index 4a479daf452..1593cac36ba 100644
--- a/src/androidterm.c
+++ b/src/androidterm.c
@@ -5402,11 +5402,22 @@ NATIVE_NAME (performContextMenuAction) (JNIEnv *env,
jobject object,
switch (action)
{
+ /* The subsequent three keycodes are addressed by
+ android_get_keysym_name rather than in keyboard.c. */
+
case 0: /* android.R.id.selectAll */
+ key = 65536 + 1;
+ break;
+
case 1: /* android.R.id.startSelectingText */
+ key = 65536 + 2;
+ break;
+
case 2: /* android.R.id.stopSelectingText */
+ key = 65536 + 3;
+ break;
+
default:
- /* These actions are not implemented. */
return;
case 3: /* android.R.id.cut */
diff --git a/src/keyboard.c b/src/keyboard.c
index c00f48d7836..13cb7835dff 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -3993,6 +3993,19 @@ kbd_buffer_get_event (KBOARD **kbp,
if (CONSP (Vunread_command_events))
break;
+#ifdef HAVE_TEXT_CONVERSION
+ /* That text conversion events take priority over keyboard
+ events, since input methods frequently send them immediately
+ after edits, with the assumption that this order of events
+ will be observed. */
+
+ if (detect_conversion_events ())
+ {
+ had_pending_conversion_events = true;
+ break;
+ }
+#endif /* HAVE_TEXT_CONVERSION */
+
if (kbd_fetch_ptr != kbd_store_ptr)
break;
if (some_mouse_moved ())
@@ -4020,13 +4033,6 @@ kbd_buffer_get_event (KBOARD **kbp,
had_pending_selection_requests = true;
break;
}
-#endif
-#ifdef HAVE_TEXT_CONVERSION
- if (detect_conversion_events ())
- {
- had_pending_conversion_events = true;
- break;
- }
#endif
if (end_time)
{
@@ -5561,9 +5567,10 @@ make_lispy_position (struct frame *f, Lisp_Object x,
Lisp_Object y,
/* Coordinate pixel positions to return. */
int xret = 0, yret = 0;
/* The window or frame under frame pixel coordinates (x,y) */
- Lisp_Object window_or_frame = f
- ? window_from_coordinates (f, mx, my, &part, true, true, true)
- : Qnil;
+ Lisp_Object window_or_frame = (f != NULL
+ ? window_from_coordinates (f, mx, my, &part,
+ false, true, true)
+ : Qnil);
#ifdef HAVE_WINDOW_SYSTEM
bool tool_bar_p = false;
bool menu_bar_p = false;
diff --git a/src/sfnt.c b/src/sfnt.c
index 7559055e8c2..8ec19290859 100644
--- a/src/sfnt.c
+++ b/src/sfnt.c
@@ -158,6 +158,7 @@ static uint32_t sfnt_table_names[] =
[SFNT_TABLE_CVAR] = 0x63766172,
[SFNT_TABLE_AVAR] = 0x61766172,
[SFNT_TABLE_OS_2] = 0x4f532f32,
+ [SFNT_TABLE_POST] = 0x706f7374,
};
/* Swap values from TrueType to system byte order. */
@@ -15474,6 +15475,69 @@ sfnt_read_OS_2_table (int fd, struct
sfnt_offset_subtable *subtable)
+/* PostScript metadata retrieval.
+
+ TrueType fonts electively incorporate a table of miscellaneous
+ information concerning such matters as the underline position or
+ whether the font is fixed pitch. This table also assigns
+ human-readable names to glyphs, subject to the table format, but
+ these names are not read by the functions defined below. */
+
+/* Read the header of a post table from the given font FD. Refer to
+ the table directory SUBTABLE for its location.
+
+ Return the post table header if successful, NULL otherwise. */
+
+TEST_STATIC struct sfnt_post_table *
+sfnt_read_post_table (int fd, struct sfnt_offset_subtable *subtable)
+{
+ struct sfnt_post_table *post;
+ struct sfnt_table_directory *directory;
+ ssize_t rc;
+
+ /* Search for the post table within SUBTABLE. */
+
+ directory = sfnt_find_table (subtable, SFNT_TABLE_POST);
+
+ if (!directory)
+ return NULL;
+
+ /* Although the size of the table is affected by its format, this
+ function is meant to read only its header; guarantee that the
+ directory is that large. */
+
+ if (directory->length < sizeof *post)
+ return NULL;
+
+ /* Seek to the location given in the directory. */
+ if (lseek (fd, directory->offset, SEEK_SET) == (off_t) -1)
+ return NULL;
+
+ post = xmalloc (sizeof *post);
+ rc = read (fd, post, sizeof *post);
+
+ if (rc == -1 || rc != sizeof *post)
+ {
+ xfree (post);
+ return NULL;
+ }
+
+ /* Byte swap the data retrieved. */
+ sfnt_swap32 (&post->format);
+ sfnt_swap32 (&post->italic_angle);
+ sfnt_swap16 (&post->underline_position);
+ sfnt_swap16 (&post->underline_thickness);
+ sfnt_swap32 (&post->is_fixed_pitch);
+ sfnt_swap32 (&post->min_mem_type_42);
+ sfnt_swap32 (&post->max_mem_type_42);
+ sfnt_swap32 (&post->min_mem_type_1);
+ sfnt_swap32 (&post->max_mem_type_1);
+
+ return post;
+}
+
+
+
#ifdef TEST
struct sfnt_test_dcontext
@@ -19359,6 +19423,7 @@ main (int argc, char **argv)
struct sfnt_avar_table *avar;
struct sfnt_cvar_table *cvar;
struct sfnt_OS_2_table *OS_2;
+ struct sfnt_post_table *post;
sfnt_fixed scale;
char *fancy;
int *advances;
@@ -19495,6 +19560,7 @@ main (int argc, char **argv)
gvar = sfnt_read_gvar_table (fd, font);
avar = sfnt_read_avar_table (fd, font);
OS_2 = sfnt_read_OS_2_table (fd, font);
+ post = sfnt_read_post_table (fd, font);
cvar = NULL;
hmtx = NULL;
@@ -19515,6 +19581,17 @@ main (int argc, char **argv)
fprintf (stderr, "OS/2 table found!\nach_vendor_id: %.4s\n",
OS_2->ach_vendor_id);
+ if (post)
+ fprintf (stderr, "post table: format: %g; italic-angle: %g;\n"
+ "underline_position: %"PRIi16"; underline_thickness: %"
+ PRIi16";\n"
+ "is_fixed_pitch: %"PRIu32"\n",
+ sfnt_coerce_fixed (post->format),
+ sfnt_coerce_fixed (post->italic_angle),
+ post->underline_position,
+ post->underline_thickness,
+ post->is_fixed_pitch);
+
if (fvar)
{
fprintf (stderr, "FVAR table found!\n"
@@ -20178,6 +20255,7 @@ main (int argc, char **argv)
xfree (avar);
xfree (cvar);
xfree (OS_2);
+ xfree (post);
return 0;
}
diff --git a/src/sfnt.h b/src/sfnt.h
index 41c1f6f74e8..f6ab6a6eebd 100644
--- a/src/sfnt.h
+++ b/src/sfnt.h
@@ -53,6 +53,7 @@ enum sfnt_table
SFNT_TABLE_CVAR,
SFNT_TABLE_AVAR,
SFNT_TABLE_OS_2,
+ SFNT_TABLE_POST,
};
#define SFNT_ENDOF(type, field, type1) \
@@ -1413,6 +1414,45 @@ struct sfnt_OS_2_table
+/* PostScript metadata. */
+
+struct sfnt_post_table
+{
+ /* Format of this table. This is a fixed point number rather than
+ an integer. */
+ sfnt_fixed format;
+
+ /* Italic angle in degrees. */
+ sfnt_fixed italic_angle;
+
+ /* Underline position. */
+ sfnt_fword underline_position;
+
+ /* Underline thickness. */
+ sfnt_fword underline_thickness;
+
+ /* Whether the font is monospaced. */
+ uint32_t is_fixed_pitch;
+
+ /* Minimum memory usage (on a PostScript printer) when a TrueType
+ font is downloaded as a Type 42 font. */
+ uint32_t min_mem_type_42;
+
+ /* Maximum memory usage (on a PostScript printer) when a TrueType
+ font is downloaded as a Type 42 font. */
+ uint32_t max_mem_type_42;
+
+ /* Minimum memory usage (on a PostScript printer) when a TrueType
+ font is downloaded as a Type 42 font. */
+ uint32_t min_mem_type_1;
+
+ /* Maximum memory usage (on a PostScript printer) when a TrueType
+ font is downloaded as a Type 42 font. */
+ uint32_t max_mem_type_1;
+};
+
+
+
#define SFNT_CEIL_FIXED(fixed) (((fixed) + 0177777) & 037777600000)
#define SFNT_FLOOR_FIXED(fixed) ((fixed) & 037777600000)
@@ -1594,6 +1634,14 @@ extern struct sfnt_OS_2_table *sfnt_read_OS_2_table
(PROTOTYPE);
#undef PROTOTYPE
+
+
+#define PROTOTYPE int, struct sfnt_offset_subtable *
+
+extern struct sfnt_post_table *sfnt_read_post_table (PROTOTYPE);
+
+#undef PROTOTYPE
+
#endif /* TEST */
diff --git a/src/sfntfont.c b/src/sfntfont.c
index 35b37396ccd..39b250ac11e 100644
--- a/src/sfntfont.c
+++ b/src/sfntfont.c
@@ -136,9 +136,6 @@ struct sfnt_font_desc
present in the font. */
Lisp_Object char_cache;
- /* Whether or not the character map can't be used by Emacs. */
- bool cmap_invalid;
-
/* The header of the cmap being used. May be invalid, in which case
platform_id will be 500. */
struct sfnt_cmap_encoding_subtable subtable;
@@ -146,6 +143,9 @@ struct sfnt_font_desc
/* The offset of the table directory within PATH. */
off_t offset;
+ /* List of font tables. */
+ struct sfnt_font_tables *tables;
+
/* The number of glyphs in this font. Used to catch invalid cmap
tables. This is actually the number of glyphs - 1. */
int num_glyphs;
@@ -153,8 +153,15 @@ struct sfnt_font_desc
/* The number of references to the font tables below. */
int refcount;
- /* List of font tables. */
- struct sfnt_font_tables *tables;
+ /* The underline position and thickness if a post table supplies
+ this information. */
+ sfnt_fword underline_position, underline_thickness;
+
+ /* Whether an underline position is available. */
+ bool_bf underline_position_set : 1;
+
+ /* Whether or not the character map can't be used by Emacs. */
+ bool cmap_invalid : 1;
};
/* List of fonts. */
@@ -962,6 +969,7 @@ sfnt_enum_font_1 (int fd, const char *file,
struct sfnt_maxp_table *maxp;
struct sfnt_fvar_table *fvar;
struct sfnt_OS_2_table *OS_2;
+ struct sfnt_post_table *post;
struct sfnt_font_desc temp;
Lisp_Object family, style, instance, style1;
int i;
@@ -1041,12 +1049,28 @@ sfnt_enum_font_1 (int fd, const char *file,
if (meta)
sfnt_parse_languages (meta, desc);
- /* Figure out the spacing. Some fancy test like what Fontconfig
- does is probably in order but not really necessary. */
- if (!NILP (Fstring_search (Fdowncase (family),
- build_string ("mono"),
- Qnil)))
- desc->spacing = 100; /* FC_MONO */
+ /* Check whether the font claims to be a fixed pitch font and forgo
+ the rudimentary detection below if so. */
+
+ post = sfnt_read_post_table (fd, subtables);
+
+ if (post)
+ {
+ desc->spacing = (post->is_fixed_pitch ? 100 : 0);
+ desc->underline_position = post->underline_position;
+ desc->underline_thickness = post->underline_thickness;
+ desc->underline_position_set = true;
+ xfree (post);
+ }
+ else
+ {
+ /* Figure out the spacing. Some fancy test like what Fontconfig
+ does is probably in order but not really necessary. */
+ if (!NILP (Fstring_search (Fdowncase (family),
+ build_string ("mono"),
+ Qnil)))
+ desc->spacing = 100; /* FC_MONO */
+ }
/* Finally add mac-style flags. Allow them to override styles that
have not been found. */
@@ -1654,6 +1678,12 @@ sfntfont_list_1 (struct sfnt_font_desc *desc,
Lisp_Object spec,
&& !sfntfont_registries_compatible_p (tem, desc->registry))
return 0;
+ /* If the font spacings disagree, reject this font also. */
+
+ tem = AREF (spec, FONT_SPACING_INDEX);
+ if (FIXNUMP (tem) && (XFIXNUM (tem) != desc->spacing))
+ return 0;
+
/* Check the style. If DESC is a fixed font, just check once.
Otherwise, check each instance. */
@@ -1869,8 +1899,7 @@ sfntfont_desc_to_entity (struct sfnt_font_desc *desc, int
instance)
/* Size of 0 means the font is scalable. */
ASET (entity, FONT_SIZE_INDEX, make_fixnum (0));
ASET (entity, FONT_AVGWIDTH_INDEX, make_fixnum (0));
- ASET (entity, FONT_SPACING_INDEX,
- make_fixnum (desc->spacing));
+ ASET (entity, FONT_SPACING_INDEX, make_fixnum (desc->spacing));
if (instance >= 1)
{
@@ -3227,8 +3256,7 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity,
/* Size of 0 means the font is scalable. */
ASET (font_object, FONT_SIZE_INDEX, make_fixnum (0));
ASET (font_object, FONT_AVGWIDTH_INDEX, make_fixnum (0));
- ASET (font_object, FONT_SPACING_INDEX,
- make_fixnum (desc->spacing));
+ ASET (font_object, FONT_SPACING_INDEX, make_fixnum (desc->spacing));
/* Set the font style. */
@@ -3249,8 +3277,21 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity,
font_info->font.relative_compose = 0;
font_info->font.default_ascent = 0;
font_info->font.vertical_centering = 0;
- font_info->font.underline_position = -1;
- font_info->font.underline_thickness = 0;
+
+ if (!desc->underline_position_set)
+ {
+ font_info->font.underline_position = -1;
+ font_info->font.underline_thickness = 0;
+ }
+ else
+ {
+ font_info->font.underline_position
+ = sfnt_coerce_fixed (-desc->underline_position
+ * font_info->scale) + 0.5;
+ font_info->font.underline_thickness
+ = sfnt_coerce_fixed (desc->underline_thickness
+ * font_info->scale) + 0.5;
+ }
/* Now try to set up grid fitting for this font. */
dpyinfo = FRAME_DISPLAY_INFO (f);
@@ -3354,6 +3395,7 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity,
/* And set a reasonable full name, namely the name of the font
file. */
font->props[FONT_FULLNAME_INDEX]
+ = font->props[FONT_FILE_INDEX]
= DECODE_FILE (build_unibyte_string (desc->path));
/* All done. */
diff --git a/src/xdisp.c b/src/xdisp.c
index 56711c190b9..253db6d9312 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -29639,9 +29639,9 @@ get_char_face_and_encoding (struct frame *f, int c, int
face_id,
}
-/* Get face and two-byte form of character glyph GLYPH on frame F.
- The encoding of GLYPH->u.ch is returned in *CHAR2B. Value is
- a pointer to a realized face that is ready for display. */
+/* Get face glyph GLYPH on frame F, and if a character glyph, its
+ multi-byte character form in *CHAR2B. Value is a pointer to a
+ realized face that is ready for display. */
static struct face *
get_glyph_face_and_encoding (struct frame *f, struct glyph *glyph,
@@ -29650,25 +29650,28 @@ get_glyph_face_and_encoding (struct frame *f, struct
glyph *glyph,
struct face *face;
unsigned code = 0;
- eassert (glyph->type == CHAR_GLYPH);
face = FACE_FROM_ID (f, glyph->face_id);
/* Make sure X resources of the face are allocated. */
prepare_face_for_display (f, face);
- if (face->font)
+ if (glyph->type == CHAR_GLYPH)
{
- if (CHAR_BYTE8_P (glyph->u.ch))
- code = CHAR_TO_BYTE8 (glyph->u.ch);
- else
- code = face->font->driver->encode_char (face->font, glyph->u.ch);
+ if (face->font)
+ {
+ if (CHAR_BYTE8_P (glyph->u.ch))
+ code = CHAR_TO_BYTE8 (glyph->u.ch);
+ else
+ code = face->font->driver->encode_char (face->font, glyph->u.ch);
- if (code == FONT_INVALID_CODE)
- code = 0;
+ if (code == FONT_INVALID_CODE)
+ code = 0;
+ }
+
+ /* Ensure that the code is only 2 bytes wide. */
+ *char2b = code & 0xFFFF;
}
- /* Ensure that the code is only 2 bytes wide. */
- *char2b = code & 0xFFFF;
return face;
}
@@ -30168,17 +30171,28 @@ normal_char_height (struct font *font, int c)
void
gui_get_glyph_overhangs (struct glyph *glyph, struct frame *f, int *left, int
*right)
{
+ unsigned char2b;
+ struct face *face;
+
*left = *right = 0;
+ face = get_glyph_face_and_encoding (f, glyph, &char2b);
if (glyph->type == CHAR_GLYPH)
{
- unsigned char2b;
- struct face *face = get_glyph_face_and_encoding (f, glyph, &char2b);
if (face->font)
{
- struct font_metrics *pcm = get_per_char_metric (face->font, &char2b);
+ struct font_metrics *pcm
+ = get_per_char_metric (face->font, &char2b);
+
if (pcm)
{
+ /* Overstruck text is displayed twice, the second time
+ one pixel to the right. Increase the right-side
+ bearing to match. */
+
+ if (face->overstrike)
+ pcm->rbearing++;
+
if (pcm->rbearing > pcm->width)
*right = pcm->rbearing - pcm->width;
if (pcm->lbearing < 0)
@@ -30191,8 +30205,18 @@ gui_get_glyph_overhangs (struct glyph *glyph, struct
frame *f, int *left, int *r
if (! glyph->u.cmp.automatic)
{
struct composition *cmp = composition_table[glyph->u.cmp.id];
+ int rbearing;
+
+ rbearing = cmp->rbearing;
- if (cmp->rbearing > cmp->pixel_width)
+ /* Overstruck text is displayed twice, the second time one
+ pixel to the right. Increase the right-side bearing to
+ match. */
+
+ if (face->overstrike)
+ rbearing++;
+
+ if (rbearing > cmp->pixel_width)
*right = cmp->rbearing - cmp->pixel_width;
if (cmp->lbearing < 0)
*left = - cmp->lbearing;
@@ -30204,6 +30228,14 @@ gui_get_glyph_overhangs (struct glyph *glyph, struct
frame *f, int *left, int *r
composition_gstring_width (gstring, glyph->slice.cmp.from,
glyph->slice.cmp.to + 1, &metrics);
+
+ /* Overstruck text is displayed twice, the second time one
+ pixel to the right. Increase the right-side bearing to
+ match. */
+
+ if (face->overstrike)
+ metrics.rbearing++;
+
if (metrics.rbearing > metrics.width)
*right = metrics.rbearing - metrics.width;
if (metrics.lbearing < 0)
@@ -32312,6 +32344,14 @@ gui_produce_glyphs (struct it *it)
if (get_char_glyph_code (it->char_to_display, font, &char2b))
{
pcm = get_per_char_metric (font, &char2b);
+
+ /* Overstruck text is displayed twice, the second time
+ one pixel to the right. Increase the right-side
+ bearing to match. */
+
+ if (pcm && face->overstrike)
+ pcm->rbearing++;
+
if (pcm->width == 0
&& pcm->rbearing == 0 && pcm->lbearing == 0)
pcm = NULL;
@@ -32704,6 +32744,13 @@ gui_produce_glyphs (struct it *it)
/* Initialize the bounding box. */
if (pcm)
{
+ /* Overstruck text is displayed twice, the second time
+ one pixel to the right. Increase the right-side
+ bearing to match. */
+
+ if (face->overstrike)
+ pcm->rbearing++;
+
width = cmp->glyph_len > 0 ? pcm->width : 0;
ascent = pcm->ascent;
descent = pcm->descent;
@@ -32765,6 +32812,13 @@ gui_produce_glyphs (struct it *it)
cmp->offsets[i * 2] = cmp->offsets[i * 2 + 1] = 0;
else
{
+ /* Overstruck text is displayed twice, the second
+ time one pixel to the right. Increase the
+ right-side bearing to match. */
+
+ if (face->overstrike)
+ pcm->rbearing++;
+
width = pcm->width;
ascent = pcm->ascent;
descent = pcm->descent;
diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml
index 6884c32848e..f106ea4d8de 100644
--- a/test/infra/gitlab-ci.yml
+++ b/test/infra/gitlab-ci.yml
@@ -193,10 +193,10 @@ default:
- if: '$CI_PIPELINE_SOURCE == "schedule"'
changes:
- "**.in"
- - lisp/emacs-lisp/comp.el
- - lisp/emacs-lisp/comp-cstr.el
+ - lisp/emacs-lisp/comp*.el
- src/comp.{h,m}
- test/infra/*
+ - test/lisp/emacs-lisp/comp*-tests.el
- test/src/comp-resources/*.el
- test/src/comp-tests.el
timeout: 8 hours
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 4aa555f1e92..06918f5901c 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -1697,7 +1697,8 @@ mountpoint (Bug#44631)."
(byte-compile-error-on-warn t))
(should-not (file-remote-p input-file))
(should-not (file-remote-p output-file))
- (write-region "" nil input-file nil nil nil 'excl)
+ (write-region ";;; -*-lexical-binding:t-*-\n"
+ nil input-file nil nil nil 'excl)
(write-region "" nil output-file nil nil nil 'excl)
(unwind-protect
(progn
diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el
index 92424d1e556..c21f3935503 100644
--- a/test/lisp/erc/erc-fill-tests.el
+++ b/test/lisp/erc/erc-fill-tests.el
@@ -27,13 +27,19 @@
(require 'erc-fill)
(defvar erc-fill-tests--buffers nil)
-(defvar erc-fill-tests--time-vals (lambda () 0))
+(defvar erc-fill-tests--current-time-value nil)
+
+(cl-defmethod erc-stamp--current-time
+ (&context (erc-fill-tests--current-time-value integer))
+ erc-fill-tests--current-time-value)
(defun erc-fill-tests--insert-privmsg (speaker &rest msg-parts)
(declare (indent 1))
(let* ((msg (erc-format-privmessage speaker
(apply #'concat msg-parts) nil t))
- (parsed (make-erc-response :unparsed msg :sender speaker
+ (parsed (make-erc-response :unparsed (format ":%s PRIVMSG #chan :%s"
+ speaker msg)
+ :sender speaker
:command "PRIVMSG"
:command-args (list "#chan" msg)
:contents msg)))
@@ -45,12 +51,11 @@
(erc-fill-function 'erc-fill-wrap)
(pre-command-hook pre-command-hook)
(inhibit-message noninteractive)
+ (erc-fill-tests--current-time-value 0)
erc-insert-post-hook
extended-command-history
erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
- (cl-letf (((symbol-function 'erc-stamp--current-time)
- (lambda () (funcall erc-fill-tests--time-vals)))
- ((symbol-function 'erc-server-connect)
+ (cl-letf (((symbol-function 'erc-server-connect)
(lambda (&rest _)
(setq erc-server-process
(start-process "sleep" (current-buffer) "sleep" "1"))
@@ -261,7 +266,7 @@
;; Set this here so that the first few messages are from 1970.
;; Following the current date stamp, the speaker isn't merged
;; even though it's continued: "<bob> zero."
- (let ((erc-fill-tests--time-vals (lambda () 1680332400)))
+ (let ((erc-fill-tests--current-time-value 1680332400))
(erc-fill-tests--insert-privmsg "bob" "zero.")
(erc-fill-tests--insert-privmsg "alice" "one.")
(erc-fill-tests--insert-privmsg "alice" "two.")
@@ -297,8 +302,8 @@
(erc-fill-tests--wrap-populate
(lambda ()
- ;; Set this here so that the first few messages are from 1970
- (let ((erc-fill-tests--time-vals (lambda () 1680332400)))
+ ;; Allow prior messages to be from 1970.
+ (let ((erc-fill-tests--current-time-value 1680332400))
(erc-fill-tests--insert-privmsg "bob" "zero.")
(erc-fill-tests--insert-privmsg "bob" "0.5")
diff --git a/test/lisp/erc/erc-scenarios-base-association.el
b/test/lisp/erc/erc-scenarios-base-association.el
index a40a4cb7550..10abe14c43b 100644
--- a/test/lisp/erc/erc-scenarios-base-association.el
+++ b/test/lisp/erc/erc-scenarios-base-association.el
@@ -78,7 +78,7 @@
(with-current-buffer "#chan@foonet"
(funcall expect 3 "bob")
(funcall expect 3 "was created on")
- (funcall expect 3 "prosperous")))
+ (funcall expect 10 "prosperous")))
(ert-info ("All #chan@barnet output consumed")
(with-current-buffer "#chan@barnet"
diff --git a/test/lisp/erc/erc-scenarios-base-buffer-display.el
b/test/lisp/erc/erc-scenarios-base-buffer-display.el
index df292a8c113..6a80baeaaa9 100644
--- a/test/lisp/erc/erc-scenarios-base-buffer-display.el
+++ b/test/lisp/erc/erc-scenarios-base-buffer-display.el
@@ -27,7 +27,10 @@
(eval-when-compile (require 'erc-join))
;; These first couple `erc-auto-reconnect-display' tests used to live
-;; in erc-scenarios-base-reconnect but have since been renamed.
+;; in erc-scenarios-base-reconnect but have since been renamed. Note
+;; that these are somewhat difficult to reason about because the user
+;; joins a second channel after reconnecting, and the first is
+;; controlled by `autojoin'.
(defun erc-scenarios-base-buffer-display--reconnect-common
(assert-server assert-chan assert-rest)
@@ -55,6 +58,7 @@
(ert-info ("Wait for some output in channels")
(with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
(funcall assert-chan expect)
+ (funcall expect 10 "welcome")
(funcall expect 10 "welcome")))
(ert-info ("Server buffer shows connection failed")
@@ -68,6 +72,10 @@
(ert-info ("Wait for auto reconnect")
(with-current-buffer "FooNet" (funcall expect 10 "still in debug mode")))
+ (ert-info ("Lone window still shows messages buffer")
+ (should (eq (window-buffer) (messages-buffer)))
+ (should (frame-root-window-p (selected-window))))
+
(funcall assert-rest expect)
(ert-info ("Wait for activity to recommence in both channels")
@@ -76,40 +84,50 @@
(with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))
(funcall expect 10 "her elves come here anon")))))
+;; Interactively issuing a slash command resets the auto-reconnect
+;; count, making ERC ignore the option `erc-auto-reconnect-display'
+;; when next displaying a newly set up buffer. In the case of a
+;; /JOIN, the option `erc-interactive-display' takes precedence.
(ert-deftest erc-scenarios-base-buffer-display--defwin-recbury-intbuf ()
:tags '(:expensive-test)
(should (eq erc-buffer-display 'bury))
(should (eq erc-interactive-display 'window))
(should-not erc-auto-reconnect-display)
- (let ((erc-buffer-display 'window)
- (erc-interactive-display 'buffer)
- (erc-auto-reconnect-display 'bury))
+ (let ((erc-buffer-display 'window) ; defwin
+ (erc-interactive-display 'buffer) ; intbuf
+ (erc-auto-reconnect-display 'bury)) ; recbury
(erc-scenarios-base-buffer-display--reconnect-common
(lambda (_)
- (should (eq (window-buffer) (current-buffer)))
- (should-not (frame-root-window-p (selected-window))))
+ (ert-info ("New server buffer appears in a selected split")
+ (should (eq (window-buffer) (current-buffer)))
+ (should-not (frame-root-window-p (selected-window)))))
(lambda (_)
- (should (eq (window-buffer) (current-buffer)))
- (should (equal (get-buffer "FooNet") (window-buffer (next-window)))))
+ (ert-info ("New channel buffer appears in other window")
+ (should (eq (window-buffer) (current-buffer))) ; selected
+ (should (equal (get-buffer "FooNet") (window-buffer (next-window))))))
+
+ (lambda (expect)
+ ;; If we /JOIN #spam now, we'll cancel the auto-reconnect
+ ;; timer, and "#chan" may well pop up in a split before we can
+ ;; verify that the lone window displays #spam (a race, IOW).
+ (ert-info ("Autojoined channel #chan buried on JOIN")
+ (with-current-buffer "#chan"
+ (funcall expect 10 "You have joined channel #chan"))
+ (should (frame-root-window-p (selected-window)))
+ (should (eq (window-buffer) (messages-buffer))))
- (lambda (_)
- (with-current-buffer "FooNet"
- (should (eq (window-buffer) (messages-buffer)))
- (should (frame-root-window-p (selected-window))))
-
- ;; A manual /JOIN command tells ERC we're done auto-reconnecting
(with-current-buffer "FooNet" (erc-scenarios-common-say "/JOIN #spam"))
- (ert-info ("#spam ignores `erc-auto-reconnect-display'")
- ;; Uses `erc-interactive-display' instead.
+ (ert-info ("A /JOIN ignores `erc-auto-reconnect-display'")
(with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))
(should (eq (window-buffer) (get-buffer "#spam")))
- ;; Option `buffer' replaces entire window (no split)
- (erc-d-t-wait-for 5 (frame-root-window-p (selected-window)))))))))
+ ;; Option `erc-interactive-display' being `buffer' means
+ ;; Emacs reuses the selected window (no split).
+ (should (frame-root-window-p (selected-window)))))))))
(ert-deftest erc-scenarios-base-buffer-display--defwino-recbury-intbuf ()
:tags '(:expensive-test)
@@ -117,7 +135,7 @@
(should (eq erc-interactive-display 'window))
(should-not erc-auto-reconnect-display)
- (let ((erc-buffer-display 'window-noselect)
+ (let ((erc-buffer-display 'window-noselect) ; defwino
(erc-auto-reconnect-display 'bury)
(erc-interactive-display 'buffer))
(erc-scenarios-base-buffer-display--reconnect-common
@@ -139,26 +157,24 @@
(should (eq (current-buffer) (window-buffer (next-window)))))
(lambda (_)
- (with-current-buffer "FooNet"
- (should (eq (window-buffer) (messages-buffer)))
- (should (frame-root-window-p (selected-window))))
-
- ;; A non-interactive JOIN command doesn't signal that we're
- ;; done auto-reconnecting, and `erc-interactive-display' is
- ;; ignored, so `erc-buffer-display' is again in charge (here,
- ;; that means `window-noselect').
- (ert-info ("Join chan noninteractively and open a /QUERY")
+ ;; A JOIN command sent from lisp code is "non-interactive" and
+ ;; doesn't reset the auto-reconnect count, so ERC treats the
+ ;; response as possibly server-initiated or otherwise the
+ ;; result of an autojoin and continues to favor
+ ;; `erc-auto-reconnect-display'.
+ (ert-info ("Join chan non-interactively and open a /QUERY")
(with-current-buffer "FooNet"
- (erc-cmd-JOIN "#spam")
- ;; However this will reset the option.
- (erc-scenarios-common-say "/QUERY bob")
+ (erc-cmd-JOIN "#spam") ; "non-interactive" according to ERC
+ (erc-scenarios-common-say "/QUERY bob") ; resets count
(should (eq (window-buffer) (get-buffer "bob")))
(should (frame-root-window-p (selected-window)))))
+ ;; The /QUERY above resets the count, and `erc-buffer-display'
+ ;; again decides how #spam is displayed.
(ert-info ("Newly joined chan ignores `erc-auto-reconnect-display'")
(with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))
(should (eq (window-buffer) (get-buffer "bob")))
- (should-not (frame-root-window-p (selected-window)))
+ (should-not (frame-root-window-p (selected-window))) ; noselect
(should (eq (current-buffer) (window-buffer (next-window))))))))))
(ert-deftest erc-scenarios-base-buffer-display--count-reset-timeout ()
@@ -177,24 +193,22 @@
(lambda (_)
(with-current-buffer "FooNet"
- (should erc--server-reconnect-display-timer)
- (should (eq (window-buffer) (messages-buffer)))
- (should (frame-root-window-p (selected-window))))
+ (should erc--server-reconnect-display-timer))
;; A non-interactive JOIN command doesn't signal that we're
- ;; done auto-reconnecting
- (ert-info ("Join chan noninteractively")
+ ;; done auto-reconnecting.
+ (ert-info ("Join channel #spam non-interactively")
(with-current-buffer "FooNet"
(erc-d-t-wait-for 1 (null erc--server-reconnect-display-timer))
- (erc-cmd-JOIN "#spam")))
+ (erc-cmd-JOIN "#spam"))) ; not processed as a /JOIN
- (ert-info ("Newly joined chan ignores `erc-auto-reconnect-display'")
- (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))
- (should (eq (window-buffer) (messages-buffer)))
- ;; If `erc-auto-reconnect-display-timeout' were left alone, this
- ;; would be (frame-root-window-p #<window 1 on *scratch*>).
- (should-not (frame-root-window-p (selected-window)))
- (should (eq (current-buffer) (window-buffer (next-window))))))))))
+ (ert-info ("Option `erc-auto-reconnect-display' ignored w/o timer")
+ (should (eq (window-buffer) (messages-buffer)))
+ (erc-d-t-wait-for 10 (get-buffer "#spam"))
+ ;; If `erc-auto-reconnect-display-timeout' were left alone,
+ ;; this would be (frame-root-window-p #<window 1 on scratch*>).
+ (should-not (frame-root-window-p (selected-window)))
+ (should (eq (get-buffer "#spam") (window-buffer (next-window)))))))))
;; This shows that the option `erc-interactive-display' overrides
;; `erc-join-buffer' during cold opens and interactive /JOINs.
diff --git a/test/lisp/erc/erc-scenarios-base-misc-regressions.el
b/test/lisp/erc/erc-scenarios-base-misc-regressions.el
index c1915d088a0..42d7653d3ec 100644
--- a/test/lisp/erc/erc-scenarios-base-misc-regressions.el
+++ b/test/lisp/erc/erc-scenarios-base-misc-regressions.el
@@ -77,7 +77,7 @@ Originally from scenario rebuffed/gapless as explained in
Bug#48598:
(with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#bar"))
(funcall expect 10 "was created on")
- (funcall expect 2 "his second fit"))
+ (funcall expect 10 "his second fit"))
(with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#foo"))
(funcall expect 10 "was created on")
@@ -108,7 +108,7 @@ Originally from scenario rebuffed/gapless as explained in
Bug#48598:
(should (string= (buffer-name) (format "127.0.0.1:%d" port)))))
(ert-info ("Server buffer is unique and temp name is absent")
- (erc-d-t-wait-for 1 (get-buffer "FooNet"))
+ (erc-d-t-wait-for 10 (get-buffer "FooNet"))
(should-not (erc-scenarios-common-buflist "127.0.0.1"))
(with-current-buffer erc-server-buffer-foo
(erc-cmd-JOIN "#chan")))
diff --git a/test/lisp/erc/erc-scenarios-stamp.el
b/test/lisp/erc/erc-scenarios-stamp.el
index b98300d04be..49307dd228a 100644
--- a/test/lisp/erc/erc-scenarios-stamp.el
+++ b/test/lisp/erc/erc-scenarios-stamp.el
@@ -113,4 +113,69 @@
(not (eq 'erc-timestamp (field-at-pos (point))))))
(should (erc--get-inserted-msg-prop 'erc-cmd)))))))
+;; This user-owned hook member places a marker on the first message in
+;; a buffer. Inserting a date stamp in front of it shouldn't move the
+;; marker.
+(defun erc-scenarios-stamp--on-insert-modify ()
+ (unless (marker-position erc-scenarios-stamp--user-marker)
+ (set-marker erc-scenarios-stamp--user-marker (point-min))
+ (save-excursion
+ (goto-char erc-scenarios-stamp--user-marker)
+ (should (looking-at "Opening"))))
+
+ ;; Sometime after the first message ("Opening connection.."), assert
+ ;; that the marker we just placed hasn't moved.
+ (when (erc--check-msg-prop 'erc-cmd 2)
+ (save-restriction
+ (widen)
+ (ert-info ("Date stamp preserves opening user marker")
+ (goto-char erc-scenarios-stamp--user-marker)
+ (should-not (eq 'erc-timestamp (field-at-pos (point))))
+ (should (looking-at "Opening"))
+ (should (eq 'unknown (get-text-property (point) 'erc-msg))))))
+
+ ;; On 003 ("*** This server was created on"), clear state to force a
+ ;; new date stamp on the next message.
+ (when (erc--check-msg-prop 'erc-cmd 3)
+ (setq erc-timestamp-last-inserted-left nil)
+ (set-marker erc-scenarios-stamp--user-marker erc-insert-marker)))
+
+(ert-deftest erc-scenarios-stamp--date-mode/left-and-right ()
+
+ (should (eq erc-insert-timestamp-function
+ #'erc-insert-timestamp-left-and-right))
+
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/reconnect")
+ (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect))
+ (port (process-contact dumb-server :service))
+ (erc-scenarios-stamp--user-marker (make-marker))
+ (erc-server-flood-penalty 0.1)
+ (erc-modules (if (zerop (random 2))
+ (cons 'fill-wrap erc-modules)
+ erc-modules))
+ (expect (erc-d-t-make-expecter))
+ (erc-mode-hook
+ (cons (lambda ()
+ (add-hook 'erc-insert-modify-hook
+ #'erc-scenarios-stamp--on-insert-modify -99 t))
+ erc-mode-hook)))
+
+ (ert-info ("Connect")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :full-name "tester"
+ :nick "tester")
+
+ (funcall expect 5 "Welcome to the foonet")
+ (funcall expect 5 "*** AWAYLEN=390")
+
+ (ert-info ("Date stamp preserves other user marker")
+ (goto-char erc-scenarios-stamp--user-marker)
+ (should-not (eq 'erc-timestamp (field-at-pos (point))))
+ (should (looking-at (rx "*** irc.foonet.org oragono")))
+ (should (eq 's004 (get-text-property (point) 'erc-msg))))
+
+ (funcall expect 5 "This server is in debug mode")))))
+
;;; erc-scenarios-stamp.el ends here
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index 1af087e7e31..916b394c8ff 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -1432,6 +1432,55 @@
(should-not calls))))))
+(ert-deftest erc--get-inserted-msg-bounds ()
+ (erc-mode)
+ (erc--initialize-markers (point) nil)
+ (let ((parsed (make-erc-response :unparsed ":bob PRIVMSG #chan :hi"
+ :sender "bob"
+ :command "PRIVMSG"
+ :command-args (list "#chan" "hi")
+ :contents "hi"))
+ (erc--msg-prop-overrides '((erc-ts . 0))))
+ (erc-display-message parsed nil (current-buffer)
+ (erc-format-privmessage "bob" "hi" nil t)))
+ (goto-char 3)
+ (should (looking-at "<bob> hi"))
+ (goto-char 11)
+ (should (looking-back "<bob> hi"))
+
+ (ert-info ("Parameter `only' being `beg'")
+ (dolist (i (number-sequence 3 11))
+ (goto-char i)
+ (ert-info ((format "At %d (%c)" i (char-after i)))
+ (should (= 3 (erc--get-inserted-msg-bounds 'beg)))))
+
+ (ert-info ("Parameter `point'")
+ (dolist (i (number-sequence 3 11))
+ (ert-info ((format "At %d (%c)" i (char-after i)))
+ (should (= 3 (erc--get-inserted-msg-bounds 'beg i)))))))
+
+ (ert-info ("Parameter `only' being `end'")
+ (dolist (i (number-sequence 3 11))
+ (goto-char i)
+ (ert-info ((format "At %d (%c)" i (char-after i)))
+ (should (= 11 (erc--get-inserted-msg-bounds 'end)))))
+
+ (ert-info ("Parameter `point'")
+ (dolist (i (number-sequence 3 11))
+ (ert-info ((format "At %d (%c)" i (char-after i)))
+ (should (= 11 (erc--get-inserted-msg-bounds 'end i)))))))
+
+ (ert-info ("Parameter `only' being nil")
+ (dolist (i (number-sequence 3 11))
+ (goto-char i)
+ (ert-info ((format "At %d (%c)" i (char-after i)))
+ (should (equal '(3 . 11) (erc--get-inserted-msg-bounds nil)))))
+
+ (ert-info ("Parameter `point'")
+ (dolist (i (number-sequence 3 11))
+ (ert-info ((format "At %d (%c)" i (char-after i)))
+ (should (equal '(3 . 11) (erc--get-inserted-msg-bounds nil i))))))))
+
(ert-deftest erc--delete-inserted-message ()
(erc-mode)
(erc--initialize-markers (point) nil)
diff --git a/test/lisp/erc/resources/base/local-modules/second.eld
b/test/lisp/erc/resources/base/local-modules/second.eld
index a96103b2aa1..5823d63b874 100644
--- a/test/lisp/erc/resources/base/local-modules/second.eld
+++ b/test/lisp/erc/resources/base/local-modules/second.eld
@@ -41,7 +41,7 @@
(0.07 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: To you that know them
not. This to my mother.")
(0.00 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Some enigma, some
riddle: come, thy l'envoy; begin."))
-((quit 1 "QUIT :\2ERC\2")
+((quit 10 "QUIT :\2ERC\2")
(0.03 ":tester`!~u@u9iqi96sfwk9s.irc QUIT"))
((drop 0 DROP))
diff --git a/test/lisp/erc/resources/base/local-modules/third.eld
b/test/lisp/erc/resources/base/local-modules/third.eld
index 19bdd6efcce..e24825c3217 100644
--- a/test/lisp/erc/resources/base/local-modules/third.eld
+++ b/test/lisp/erc/resources/base/local-modules/third.eld
@@ -37,7 +37,7 @@
(0.00 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: No remedy, my lord,
when walls are so wilful to hear without warning.")
(0.01 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Let our reciprocal
vows be remembered. You have many opportunities to cut him off; if your will
want not, time and place will be fruitfully offered. There is nothing done if
he return the conqueror; then am I the prisoner, and his bed my gaol; from the
loathed warmth whereof deliver me, and supply the place for your labor."))
-((quit 1 "QUIT :\2ERC\2")
+((quit 10 "QUIT :\2ERC\2")
(0.03 ":tester`!~u@u9iqi96sfwk9s.irc QUIT :Quit"))
((drop 0 DROP))
diff --git a/test/lisp/erc/resources/base/reconnect/options-again.eld
b/test/lisp/erc/resources/base/reconnect/options-again.eld
index f1fcc439cc3..8a3264fda9c 100644
--- a/test/lisp/erc/resources/base/reconnect/options-again.eld
+++ b/test/lisp/erc/resources/base/reconnect/options-again.eld
@@ -32,13 +32,13 @@
(0 ":irc.foonet.org 353 tester = #spam :alice tester @bob")
(0 ":irc.foonet.org 366 tester #spam :End of NAMES list"))
-((~mode-chan 4 "MODE #chan")
+((~mode-chan 10 "MODE #chan")
(0 ":irc.foonet.org 324 tester #chan +nt")
(0 ":irc.foonet.org 329 tester #chan 1620104779")
(0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :alice: But, as it seems, did
violence on herself.")
(0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :bob: Well, this is the
forest of Arden."))
-((mode-spam 4 "MODE #spam")
+((mode-spam 20 "MODE #spam")
(0 ":irc.foonet.org 324 tester #spam +nt")
(0 ":irc.foonet.org 329 tester #spam 1620104779")
(0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #spam :alice: Signior Iachimo will
not from it. Pray, let us follow 'em.")
diff --git a/test/lisp/erc/resources/dcc/chat/accept.eld
b/test/lisp/erc/resources/dcc/chat/accept.eld
index a23e9580bcc..463f931d26f 100644
--- a/test/lisp/erc/resources/dcc/chat/accept.eld
+++ b/test/lisp/erc/resources/dcc/chat/accept.eld
@@ -17,7 +17,7 @@
(0 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4")
(0 ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 1.2 "MODE tester +i")
+((mode-user 10 "MODE tester +i")
;; No mode answer
(0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is
logging all user I/O. If you do not wish for everything you send to be readable
by the server owner(s), please disconnect.")
(0.2 ":dummy!~u@34n9brushbpj2.irc PRIVMSG tester :\C-aDCC CHAT chat
2130706433 " port "\C-a"))
diff --git a/test/lisp/erc/resources/erc-d/erc-d.el
b/test/lisp/erc/resources/erc-d/erc-d.el
index f072c6b93b2..a87904e5830 100644
--- a/test/lisp/erc/resources/erc-d/erc-d.el
+++ b/test/lisp/erc/resources/erc-d/erc-d.el
@@ -297,7 +297,7 @@ With int SKIP, advance past that many exchanges."
(when erc-d--m-debug
(setq format-string (concat (format-time-string "%s.%N: ") format-string)))
(let ((insertp (and process erc-d--in-process))
- (buffer (process-buffer (process-get process :server))))
+ (buffer (and process (process-buffer (process-get process :server)))))
(when (and insertp (buffer-live-p buffer))
(princ (concat (apply #'format format-string args) "\n") buffer))
(when (or erc-d--m-debug (not insertp))
diff --git a/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld
b/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld
index e5532980644..2db750e49da 100644
--- a/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld
+++ b/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld
@@ -17,7 +17,7 @@
(0. ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
(0. ":irc.foonet.org 422 tester :MOTD File is missing"))
-((mode-user 2 "MODE tester +i")
+((mode-user 4 "MODE tester +i")
(0. ":irc.foonet.org 221 tester +Zi")
(0. ":irc.foonet.org 306 tester :You have been marked as being away")
(0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan")
diff --git a/test/lisp/erc/resources/erc-scenarios-common.el
b/test/lisp/erc/resources/erc-scenarios-common.el
index 9e134e6932f..802ccaeedaa 100644
--- a/test/lisp/erc/resources/erc-scenarios-common.el
+++ b/test/lisp/erc/resources/erc-scenarios-common.el
@@ -455,7 +455,7 @@ buffer-naming collisions involving bouncers in ERC."
:id foo-id))
(setq erc-server-process-foo erc-server-process)
(erc-scenarios-common-assert-initial-buf-name foo-id port)
- (erc-d-t-wait-for 3 (eq (erc-network) 'foonet))
+ (erc-d-t-wait-for 6 (eq (erc-network) 'foonet))
(erc-d-t-wait-for 3 (string= (buffer-name) serv-buf-foo))
(funcall expect 5 "foonet")))
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld
b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld
index 8a6f2289f5d..c07eee3517f 100644
--- a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld
+++ b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld
@@ -1 +1 @@
-#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging
all user I/O. If you do not wish for everything you send to be readable by the
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause
to complain of? Come me to what was done to her.\n<bob> alice: Either your
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1
2023]\n<bob> zero.[07:00]\n<alic [...]
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging
all user I/O. If you do not wish for everything you send to be readable by the
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause
to complain of? Come me to what was done to her.\n<bob> alice: Either your
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1
2023]\n<bob> zero.[07:00]\n<alic [...]
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld
b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld
index 3eb4be4919b..cf5cdb4f825 100644
--- a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld
+++ b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld
@@ -1 +1 @@
-#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging
all user I/O. If you do not wish for everything you send to be readable by the
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause
to complain of? Come me to what was done to her.\n<bob> alice: Either your
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1
2023]\n<bob> zero.[07:00]\n<alic [...]
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging
all user I/O. If you do not wish for everything you send to be readable by the
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause
to complain of? Come me to what was done to her.\n<bob> alice: Either your
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1
2023]\n<bob> zero.[07:00]\n<alic [...]
diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld
b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld
index f966daeed1f..ad4e6483f01 100644
--- a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld
+++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld
@@ -1 +1 @@
-#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging
all user I/O. If you do not wish for everything you send to be readable by the
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause
to complain of? Come me to what was done to her.\n<bob> alice: Either your
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1
2023]\n<bob> zero.[07:00]\n<bob> [...]
\ No newline at end of file
+#("\n\n\n[Thu Jan 1 1970]\n*** This server is in debug mode and is logging
all user I/O. If you do not wish for everything you send to be readable by the
server owner(s), please disconnect.[00:00]\n<alice> bob: come, you are a
tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause
to complain of? Come me to what was done to her.\n<bob> alice: Either your
unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1
2023]\n<bob> zero.[07:00]\n<bob> [...]
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index 63ce4dab7eb..3492bd701b2 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -1717,6 +1717,157 @@ let-bound to PRED and passing nil as second arg of
(set-buffer-modified-p nil)
(kill-buffer buf)))))))
+(defmacro files-tests--with-yes-or-no-p (reply &rest body)
+ "Execute BODY, providing replies to `yes-or-no-p' queries.
+REPLY should be a cons (PROMPT . VALUE), and during execution of
+BODY this macro provides VALUE as return value to all
+`yes-or-no-p' calls prompting for PROMPT and nil to all other
+`yes-or-no-p' calls. After execution of BODY, this macro ensures
+that exactly one `yes-or-no-p' call prompting for PROMPT has been
+executed during execution of BODY."
+ (declare (indent 1) (debug (sexp body)))
+ `(cl-letf*
+ ((reply ,reply)
+ (prompts nil)
+ ((symbol-function 'yes-or-no-p)
+ (lambda (prompt)
+ (let ((reply (cdr (assoc prompt (list reply)))))
+ (push (cons prompt reply) prompts)
+ reply))))
+ ,@body
+ (should (equal prompts (list reply)))))
+
+(ert-deftest files-tests-save-buffer-read-only-file ()
+ "Test writing to write-protected files with `save-buffer'.
+Ensure that the issues from bug#66546 are fixed."
+ (ert-with-temp-directory dir
+ (cl-flet (;; Define convenience functions.
+ (file-contents (file)
+ (if (file-exists-p file)
+ (condition-case err
+ (with-temp-buffer
+ (insert-file-contents-literally file)
+ (buffer-string))
+ (error err))
+ 'missing))
+ (signal-write-failed (&rest _)
+ (signal 'file-error "Write failed")))
+
+ (let* (;; Sanitize environment.
+ ;; The tests below test text for equality, so we need to
+ ;; disable any code- and EOL-conversions to avoid false
+ ;; positives and false negatives.
+ (coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion)
+ (auto-save-default nil)
+ (backup-enable-predicate nil)
+ (before-save-hook nil)
+ (write-contents-functions nil)
+ (write-file-functions nil)
+ (after-save-hook nil)
+
+ ;; Set the name of the game.
+ (base "read-only-test")
+ (file (expand-file-name base dir))
+ (backup (make-backup-file-name file))
+
+ (override-read-only-prompt
+ (format "File %s is write-protected; try to save anyway? "
+ base)))
+
+ ;; Ensure that set-file-modes renders our test file read-only,
+ ;; otherwise skip this test. Use `file-writable-p' to test
+ ;; for read-only-ness, because that's what function
+ ;; `save-buffer' uses as well.
+ (with-temp-file file (insert "foo\n"))
+ (skip-unless (file-writable-p file))
+ (set-file-modes file (logand (file-modes file)
+ (lognot #o0222)))
+ (skip-unless (not (file-writable-p file)))
+
+ (with-current-buffer (find-file-noselect file)
+ ;; Prepare for tests backing up the file.
+ (setq buffer-read-only nil)
+ (goto-char (point-min))
+ (insert "bar\n")
+
+ ;; Save to read-only file with backup, declining prompt.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt nil)
+ (should-error
+ (save-buffer)
+ ;; "Attempt to save to a file that you aren't allowed to write"
+ :type 'error))
+ (should-not buffer-backed-up)
+ (should (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should (equal (file-contents file) "foo\n"))
+ (should (equal (file-contents backup) 'missing))
+
+ ;; Save to read-only file with backup, accepting prompt,
+ ;; experiencing a write error.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt t)
+ (should-error
+ (cl-letf (((symbol-function 'write-region)
+ #'signal-write-failed))
+ (save-buffer))
+ ;; "Write failed"
+ :type 'file-error))
+ (should-not buffer-backed-up)
+ (should (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should (equal (file-contents file) "foo\n"))
+ (should (equal (file-contents backup) 'missing))
+
+ ;; Save to read-only file with backup, accepting prompt.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt t)
+ (save-buffer))
+ (should buffer-backed-up)
+ (should-not (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should-not (file-writable-p backup))
+ (should (equal (file-contents file) "bar\nfoo\n"))
+ (should (equal (file-contents backup) "foo\n"))
+
+ ;; Prepare for tests not backing up the file.
+ (setq buffer-backed-up nil)
+ (delete-file backup)
+ (goto-char (point-min))
+ (insert "baz\n")
+
+ ;; Save to read-only file without backup, accepting prompt,
+ ;; experiencing a write error. This tests that issue B of
+ ;; bug#66546 is fixed. The results of the "with backup" and
+ ;; "without backup" subtests are identical when a write
+ ;; error occurs, but the code paths to reach these results
+ ;; are not. In other words, this subtest is not redundant.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt t)
+ (should-error
+ (cl-letf (((symbol-function 'write-region)
+ #'signal-write-failed))
+ (save-buffer 0))
+ ;; "Write failed"
+ :type 'file-error))
+ (should-not buffer-backed-up)
+ (should (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should (equal (file-contents file) "bar\nfoo\n"))
+ (should (equal (file-contents backup) 'missing))
+
+ ;; Save to read-only file without backup, accepting prompt.
+ ;; This tests that issue A of bug#66546 is fixed.
+ (files-tests--with-yes-or-no-p
+ (cons override-read-only-prompt t)
+ (save-buffer 0))
+ (should-not buffer-backed-up)
+ (should-not (buffer-modified-p))
+ (should-not (file-writable-p file))
+ (should (equal (file-contents file) "baz\nbar\nfoo\n"))
+ (should (equal (file-contents backup) 'missing)))))))
+
(ert-deftest files-tests-save-some-buffers ()
"Test `save-some-buffers'.
Test the 3 cases for the second argument PRED, i.e., nil, t, or
diff --git a/test/lisp/mh-e/test-all-mh-variants.sh
b/test/lisp/mh-e/test-all-mh-variants.sh
index 5e6b26fd2ec..602d831e28c 100755
--- a/test/lisp/mh-e/test-all-mh-variants.sh
+++ b/test/lisp/mh-e/test-all-mh-variants.sh
@@ -81,8 +81,10 @@ for path in "${mh_sys_path[@]}"; do
fi
echo "** Testing with PATH $path"
((++tests_total))
+ # The LD_LIBRARY_PATH setting is needed
+ # to run locally installed Mailutils.
TEST_MH_PATH=$path TEST_MH_DEBUG=$debug \
- HOME=/nonexistent \
+ LD_LIBRARY_PATH=/usr/local/lib HOME=/nonexistent \
"${emacs[@]}" -l ert \
--eval "(setq load-prefer-newer t)" \
--eval "(load \"$PWD/test/lisp/mh-e/mh-utils-tests\" nil t)" \
diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el
index 4f92d7f841c..27d71805502 100644
--- a/test/lisp/minibuffer-tests.el
+++ b/test/lisp/minibuffer-tests.el
@@ -420,6 +420,21 @@
(next-completion 5)
(should (equal "ac" (get-text-property (point) 'completion--string)))
(previous-completion 5)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+
+ (first-completion)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (next-line-completion 2)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (next-line-completion 5)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 5)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (goto-char (point-min))
+ (next-line-completion 5)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (goto-char (point-min))
+ (previous-line-completion 5)
(should (equal "aa" (get-text-property (point) 'completion--string)))))
(let ((completion-auto-wrap t))
(completing-read-with-minibuffer-setup
@@ -433,6 +448,21 @@
(next-completion 1)
(should (equal "aa" (get-text-property (point) 'completion--string)))
(previous-completion 1)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+
+ (first-completion)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (next-line-completion 2)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (next-line-completion 1)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 1)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (goto-char (point-min))
+ (next-line-completion 4)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (goto-char (point-min))
+ (previous-line-completion 4)
(should (equal "ac" (get-text-property (point) 'completion--string))))))
(ert-deftest completions-header-format-test ()
@@ -454,6 +484,16 @@
(should (equal "ac" (get-text-property (point) 'completion--string)))
(next-completion 1)
(should (equal "aa" (get-text-property (point) 'completion--string)))
+
+ (next-line-completion 2)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 2)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 1)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (next-line-completion 1)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+
;; Fixed in bug#55430
(execute-kbd-macro (kbd "C-u RET"))
(should (equal (minibuffer-contents) "aa")))
@@ -488,8 +528,58 @@
;; Fixed in bug#54374
(goto-char (1- (point-max)))
(should-not (equal 'highlight (get-text-property (point) 'mouse-face)))
+
+ (first-completion)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (let ((completion-auto-wrap t))
+ (next-line-completion 3))
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (let ((completion-auto-wrap nil))
+ (next-line-completion 3))
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+
(execute-kbd-macro (kbd "C-u RET"))
(should (equal (minibuffer-contents) "ac")))))
+(ert-deftest completions-group-navigation-test ()
+ (completing-read-with-minibuffer-setup
+ (lambda (string pred action)
+ (if (eq action 'metadata)
+ `(metadata
+ (group-function
+ . ,(lambda (name transform)
+ (if transform
+ name
+ (pcase name
+ (`"aa" "Group 1")
+ (`"ab" "Group 2")
+ (`"ac" "Group 3")))))
+ (category . unicode-name))
+ (complete-with-action action '("aa" "ab" "ac") string pred)))
+ (insert "a")
+ (minibuffer-completion-help)
+ (switch-to-completions)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (let ((completion-auto-wrap t))
+ (next-completion 3))
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (let ((completion-auto-wrap nil))
+ (next-completion 3))
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+
+ (first-completion)
+ (let ((completion-auto-wrap t))
+ (next-line-completion 1)
+ (should (equal "ab" (get-text-property (point) 'completion--string)))
+ (next-line-completion 2)
+ (should (equal "aa" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 2)
+ (should (equal "ab" (get-text-property (point) 'completion--string))))
+ (let ((completion-auto-wrap nil))
+ (next-line-completion 3)
+ (should (equal "ac" (get-text-property (point) 'completion--string)))
+ (previous-line-completion 3)
+ (should (equal "aa" (get-text-property (point) 'completion--string))))))
+
(provide 'minibuffer-tests)
;;; minibuffer-tests.el ends here
diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el
index 341c40b617b..c1036f636e5 100644
--- a/test/lisp/time-stamp-tests.el
+++ b/test/lisp/time-stamp-tests.el
@@ -89,12 +89,12 @@
(iter-defun time-stamp-test-pattern-sequential ()
"Iterate through each possibility for a part of `time-stamp-pattern'."
(let ((pattern-value-parts
- '(("4/" "10/" "-9/" "0/" "") ;0: line limit
- ("stamp<" "") ;1: start
- ("%-d" "%_H" "%^a" "%#Z" "%:A" "%09z" "%%" "") ;2: format part 1
- (" " "x" ":" "\n" "") ;3: format part 2
- ("%-d" "%_H" "%^a" "%#Z" "%:A" "%09z" "%%") ;4: format part 3
- (">end" "")))) ;5: end
+ '(("4/" "10/" "-9/" "0/" "") ;0: line limit
+ ("stamp:" "") ;1: start
+ ("%-d" "%_H" "%^a" "%#Z" "%:A" "%019z" "%%" "") ;2: format part 1
+ (" " "x" ":" "\n" "") ;3: format part 2
+ ("%-d" "%_H" "%^a" "%#Z" "%:A" "%019z" "%%") ;4: format part 3
+ ("end" "")))) ;5: end
(dotimes (cur (length pattern-value-parts))
(dotimes (cur-index (length (nth cur pattern-value-parts)))
(cl-flet ((extract-part
@@ -118,15 +118,21 @@
(iter-defun time-stamp-test-pattern-multiply ()
"Iterate through every combination of parts of `time-stamp-pattern'."
(let ((line-limit-values '("" "4/"))
- (start-values '("" "/stamp/"))
- (format-values '("%%" "%m"))
+ (start-values '("" "/stamp1/"))
+ (format-values '("" "%%" "%m"))
(end-values '("" ">end")))
;; yield all combinations of the above
(dolist (line-limit line-limit-values)
(dolist (start start-values)
(dolist (format format-values)
(dolist (end end-values)
- (iter-yield (list line-limit start format end))))))))
+ ;; If the format is not supplied, the end cannot be either,
+ ;; so not all generated combinations are valid.
+ ;; (This is why the format can be supplied as "%%" to
+ ;; preserve the default format.)
+ (if (or (not (equal format ""))
+ (equal end ""))
+ (iter-yield (list line-limit start format end)))))))))
(iter-defun time-stamp-test-pattern-all ()
(iter-yield-from (time-stamp-test-pattern-sequential))
@@ -156,7 +162,8 @@
(if (equal start1 "")
(should (equal ts-start time-stamp-start))
(should (equal ts-start start1)))
- (if (equal whole-format "%%")
+ (if (or (equal whole-format "")
+ (equal whole-format "%%"))
(should (equal ts-format time-stamp-format))
(should (equal ts-format whole-format)))
(if (equal end1 "")
@@ -165,7 +172,8 @@
;; return nil to stop time-stamp from calling us again
nil)))
(let ((time-stamp-pattern (concat
- line-limit1 start1 whole-format end1)))
+ line-limit1 start1 whole-format end1))
+ (case-fold-search nil))
(with-temp-buffer
;; prep the buffer with more than the
;; largest line-limit1 number of lines
@@ -758,12 +766,14 @@ and is called by some low-level `time-stamp' \"%z\" unit
tests."
(defun fz-make+zone (h &optional m s)
"Creates a non-negative offset."
+ (declare (pure t))
(let ((m (or m 0))
(s (or s 0)))
(+ (* 3600 h) (* 60 m) s)))
(defun fz-make-zone (h &optional m s)
"Creates a negative offset. The arguments are all non-negative."
+ (declare (pure t))
(- (fz-make+zone h m s)))
(defmacro formatz-should-equal (zone expect)
diff --git a/test/src/comp-resources/comp-test-funcs.el
b/test/src/comp-resources/comp-test-funcs.el
index 6d0cb353513..85282e4dc97 100644
--- a/test/src/comp-resources/comp-test-funcs.el
+++ b/test/src/comp-resources/comp-test-funcs.el
@@ -242,6 +242,10 @@
(defun comp-tests-lambda-return-f ()
(lambda (x) (1+ x)))
+(defun comp-tests-lambda-return-f2 ()
+ (lambda ()
+ (lambda (x) (1+ x))))
+
(defun comp-tests-fib-f (n)
(cond ((= n 0) 0)
((= n 1) 1)
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 2b3c3dd4c75..c2f0af51570 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -327,6 +327,14 @@ Check that the resulting binaries do not differ."
(should (subr-native-elisp-p f))
(should (= (funcall f 3) 4))))
+(comp-deftest lambda-return2 ()
+ "Check a nested lambda function gets native compiled."
+ (let ((f (comp-tests-lambda-return-f2)))
+ (should (subr-native-elisp-p f))
+ (let ((f2 (funcall f)))
+ (should (subr-native-elisp-p f2))
+ (should (= (funcall f2 3) 4)))))
+
(comp-deftest recursive ()
(should (= (comp-tests-fib-f 10) 55)))
@@ -388,7 +396,27 @@ Check that the resulting binaries do not differ."
"Some doc."))
(should (commandp #'comp-tests-free-fun-f))
(should (equal (interactive-form #'comp-tests-free-fun-f)
- '(interactive))))
+ '(interactive nil))))
+
+(declare-function comp-tests-free-fun-f2 nil)
+
+(comp-deftest free-fun2 ()
+ "Check compiling a symbol's function compiles contained lambdas."
+ (eval '(defun comp-tests-free-fun-f2 ()
+ (lambda (x)
+ "Some doc."
+ (interactive)
+ x)))
+ (native-compile #'comp-tests-free-fun-f2)
+
+ (let* ((f (symbol-function 'comp-tests-free-fun-f2))
+ (f2 (funcall f)))
+ (should (subr-native-elisp-p f))
+ (should (subr-native-elisp-p f2))
+ (should (string= (documentation f2) "Some doc."))
+ (should (commandp f2))
+ (should (equal (interactive-form f2) '(interactive nil)))
+ (should (= (funcall f2 3) 3))))
(declare-function comp-tests/free\fun-f nil)
diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el
index 4308e4048f6..791e902bd0a 100644
--- a/test/src/treesit-tests.el
+++ b/test/src/treesit-tests.el
@@ -166,6 +166,13 @@
;; `treesit-node-eq'.
(should (treesit-node-eq root-node root-node))
(should (not (treesit-node-eq root-node doc-node)))
+ ;; `treesit-node-enclosed-p'
+ (should (treesit-node-enclosed-p '(1 . 3) '(1 . 4)))
+ (should (treesit-node-enclosed-p '(1 . 3) '(1 . 3)))
+ (should (not (treesit-node-enclosed-p '(1 . 3) '(1 . 4) t)))
+ (should (treesit-node-enclosed-p '(1 . 3) '(1 . 4) 'partial))
+ (should (treesit-node-enclosed-p '(2 . 3) '(1 . 4) t))
+ (should (treesit-node-enclosed-p object-node root-node))
;; Further test for `treesit-node-check'.
(treesit-parser-delete parser)