[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
feature/type-hierarchy 1fbe56c3276 1/2: Merge remote-tracking branch 'or
|
From: |
Andrea Corallo |
|
Subject: |
feature/type-hierarchy 1fbe56c3276 1/2: Merge remote-tracking branch 'origin/master' into 'feature/type-hierarchy' |
|
Date: |
Wed, 28 Feb 2024 15:17:17 -0500 (EST) |
branch: feature/type-hierarchy
commit 1fbe56c32761efdc8d268df80a97a9102d00e109
Merge: 6de60f33ed5 05195e129fc
Author: Andrea Corallo <acorallo@gnu.org>
Commit: Andrea Corallo <acorallo@gnu.org>
Merge remote-tracking branch 'origin/master' into 'feature/type-hierarchy'
---
.dir-locals.el | 12 +-
.mailmap | 6 +-
BUGS | 4 +
CONTRIBUTE | 46 +-
ChangeLog.3 | 4 +-
GNUmakefile | 50 +-
admin/CPP-DEFINES | 15 +-
admin/authors.el | 3 +
admin/codespell/codespell.exclude | 2 +
admin/gitmerge.el | 8 +-
admin/merge-gnulib | 2 +-
admin/notes/kind-communication | 21 +
admin/notes/tree-sitter/build-module/build.sh | 2 +-
configure.ac | 16 +-
cross/verbose.mk.android | 13 +-
doc/emacs/basic.texi | 17 +-
doc/emacs/buffers.texi | 2 +-
doc/emacs/display.texi | 8 +
doc/emacs/help.texi | 5 +
doc/emacs/text.texi | 6 +
doc/lispref/abbrevs.texi | 2 +-
doc/lispref/compile.texi | 66 -
doc/lispref/control.texi | 10 +
doc/lispref/elisp.texi | 2 +-
doc/lispref/intro.texi | 6 +-
doc/lispref/minibuf.texi | 8 +
doc/lispref/modes.texi | 71 +-
doc/lispref/objects.texi | 5 +-
doc/lispref/package.texi | 48 +
doc/lispref/parsing.texi | 33 +-
doc/lispref/sequences.texi | 40 +-
doc/lispref/symbols.texi | 82 +-
doc/misc/epa.texi | 9 +
doc/misc/erc.texi | 33 +-
doc/misc/eshell.texi | 703 ++++++---
doc/misc/gnus.texi | 14 +-
doc/misc/texinfo.tex | 37 +-
doc/misc/tramp.texi | 34 +-
doc/translations/README | 211 +++
doc/{lang => translations}/fr/misc/ses-fr.texi | 0
etc/ERC-NEWS | 30 +-
etc/NEWS | 226 ++-
etc/NEWS.25 | 5 +
etc/PROBLEMS | 47 +-
etc/emacs_lldb.py | 1 +
etc/images/README | 7 +-
etc/images/conceal.pbm | Bin 0 -> 41 bytes
etc/images/conceal.svg | 4 +
etc/images/reveal.pbm | Bin 0 -> 41 bytes
etc/images/reveal.svg | 4 +
java/debug.sh | 13 +-
java/org/gnu/emacs/EmacsActivity.java | 36 +-
java/org/gnu/emacs/EmacsContextMenu.java | 17 +-
java/org/gnu/emacs/EmacsService.java | 90 +-
java/org/gnu/emacs/EmacsWindow.java | 101 +-
leim/Makefile.in | 6 +-
lib-src/Makefile.in | 4 +-
lib/cdefs.h | 4 +-
lib/gnulib.mk.in | 9 +-
lib/limits.in.h | 2 +-
lib/nstrftime.c | 1501 +-------------------
lib/{nstrftime.c => strftime.c} | 575 +++++++-
lib/strftime.h | 73 +-
lib/string.in.h | 14 +-
lib/time.in.h | 20 +-
lib/time_r.c | 5 +
lib/warn-on-use.h | 4 +
lib/xalloc-oversized.h | 3 +-
lisp/abbrev.el | 5 +-
lisp/allout.el | 6 +-
lisp/auth-source.el | 2 +-
lisp/bind-key.el | 1 +
lisp/buff-menu.el | 41 +-
lisp/cedet/mode-local.el | 4 +-
lisp/cedet/semantic/lex-spp.el | 6 +-
lisp/cedet/semantic/lex.el | 4 +-
lisp/comint.el | 2 +-
lisp/completion-preview.el | 24 +-
lisp/completion.el | 8 +-
lisp/cus-edit.el | 35 +
lisp/cus-face.el | 2 +-
lisp/cus-start.el | 1 +
lisp/desktop.el | 17 +-
lisp/dired.el | 5 +
lisp/emacs-lisp/bytecomp.el | 633 ++++-----
lisp/emacs-lisp/cconv.el | 12 +-
lisp/emacs-lisp/check-declare.el | 116 +-
lisp/emacs-lisp/checkdoc.el | 2 +-
lisp/emacs-lisp/cl-generic.el | 74 +-
lisp/emacs-lisp/cl-macs.el | 18 +-
lisp/emacs-lisp/cl-preloaded.el | 2 +-
lisp/emacs-lisp/comp-common.el | 5 +-
lisp/emacs-lisp/comp-cstr.el | 30 +-
lisp/emacs-lisp/comp-run.el | 2 +-
lisp/emacs-lisp/comp.el | 1076 +++++++-------
lisp/emacs-lisp/compat.el | 92 ++
lisp/emacs-lisp/derived.el | 131 --
lisp/emacs-lisp/disass.el | 2 -
lisp/emacs-lisp/easy-mmode.el | 2 +-
lisp/emacs-lisp/edebug.el | 29 +-
lisp/emacs-lisp/eieio.el | 4 +-
lisp/emacs-lisp/eldoc.el | 4 +-
lisp/emacs-lisp/elint.el | 1 +
lisp/emacs-lisp/find-func.el | 1 +
lisp/emacs-lisp/inline.el | 4 +-
lisp/emacs-lisp/lisp-mode.el | 6 +-
lisp/emacs-lisp/loaddefs-gen.el | 73 +-
lisp/emacs-lisp/map.el | 28 +-
lisp/emacs-lisp/package-vc.el | 19 +-
lisp/emacs-lisp/package.el | 3 +-
lisp/emacs-lisp/pcase.el | 57 +-
lisp/emacs-lisp/seq.el | 4 +-
lisp/emacs-lisp/shortdoc.el | 33 +-
lisp/emacs-lisp/shorthands.el | 34 +-
lisp/emacs-lisp/trace.el | 2 +-
lisp/epa-ks.el | 3 -
lisp/epa.el | 34 +-
lisp/erc/erc-backend.el | 24 +-
lisp/erc/erc-common.el | 2 +-
lisp/erc/erc-compat.el | 48 +-
lisp/erc/erc-fill.el | 64 +-
lisp/erc/erc-goodies.el | 2 +-
lisp/erc/erc-networks.el | 25 +-
lisp/erc/erc-speedbar.el | 5 +-
lisp/erc/erc-stamp.el | 40 +-
lisp/erc/erc.el | 165 ++-
lisp/eshell/em-unix.el | 14 +-
lisp/eshell/esh-arg.el | 2 +-
lisp/eshell/esh-ext.el | 6 +-
lisp/eshell/esh-mode.el | 18 +-
lisp/eshell/esh-opt.el | 62 +-
lisp/eshell/esh-var.el | 2 +-
lisp/faces.el | 4 +-
lisp/ffap.el | 4 +-
lisp/files.el | 25 +-
lisp/filesets.el | 44 +-
lisp/forms.el | 2 +-
lisp/gnus/gnus-agent.el | 8 +-
lisp/gnus/gnus-art.el | 2 +-
lisp/gnus/gnus-dired.el | 9 +-
lisp/gnus/gnus-msg.el | 4 +-
lisp/gnus/gnus-score.el | 11 +-
lisp/gnus/gnus-util.el | 3 +-
lisp/gnus/gnus.el | 30 +-
lisp/gnus/nnheader.el | 2 +-
lisp/help-fns.el | 102 +-
lisp/help-mode.el | 12 +-
lisp/help.el | 33 +-
lisp/ielm.el | 29 +
lisp/image.el | 26 +-
lisp/info.el | 35 +-
lisp/international/titdic-cnv.el | 119 +-
lisp/loadup.el | 2 +
lisp/mail/mail-extr.el | 2 +-
lisp/mail/mailabbrev.el | 12 +-
lisp/mail/rmail.el | 182 +--
lisp/mail/rmailkwd.el | 2 +-
lisp/menu-bar.el | 9 +
lisp/minibuffer.el | 30 +-
lisp/mpc.el | 13 +-
lisp/net/browse-url.el | 8 +-
lisp/net/dns.el | 2 +-
lisp/net/eww.el | 2 +-
lisp/net/imap.el | 8 +-
lisp/net/shr.el | 76 +-
lisp/net/tramp-adb.el | 32 +-
lisp/net/tramp-androidsu.el | 577 ++++++++
lisp/net/tramp-archive.el | 4 +-
lisp/net/tramp-cache.el | 105 +-
lisp/net/tramp-compat.el | 4 +-
lisp/net/tramp-container.el | 60 +-
lisp/net/tramp-gvfs.el | 7 +-
lisp/net/tramp-integration.el | 2 +-
lisp/net/tramp-message.el | 4 +
lisp/net/tramp-sh.el | 67 +-
lisp/net/tramp-sshfs.el | 4 +-
lisp/net/tramp-sudoedit.el | 2 +-
lisp/net/tramp.el | 87 +-
lisp/obarray.el | 24 +-
lisp/obsolete/iswitchb.el | 4 +-
lisp/obsolete/longlines.el | 14 +-
lisp/obsolete/pgg.el | 4 +-
lisp/obsolete/rcompile.el | 14 +-
lisp/org/org.el | 2 +-
lisp/outline.el | 28 +-
lisp/play/cookie1.el | 2 +-
lisp/proced.el | 2 +-
lisp/progmodes/c-ts-mode.el | 15 +
lisp/progmodes/cc-defs.el | 7 +-
lisp/progmodes/cc-langs.el | 2 +-
lisp/progmodes/cmake-ts-mode.el | 18 +-
lisp/progmodes/compile.el | 16 +-
lisp/progmodes/cperl-mode.el | 13 +-
lisp/progmodes/eglot.el | 12 +-
lisp/progmodes/elisp-mode.el | 44 +-
lisp/progmodes/elixir-ts-mode.el | 56 +-
lisp/progmodes/etags.el | 4 +-
lisp/progmodes/flymake.el | 20 +-
lisp/progmodes/gud.el | 2 +-
lisp/progmodes/heex-ts-mode.el | 10 +
lisp/progmodes/hideif.el | 14 +-
lisp/progmodes/idlw-shell.el | 4 +-
lisp/progmodes/java-ts-mode.el | 13 +-
lisp/progmodes/js.el | 27 +-
lisp/progmodes/lua-ts-mode.el | 18 +-
lisp/progmodes/modula2.el | 47 +-
lisp/progmodes/opascal.el | 2 +-
lisp/progmodes/project.el | 14 +-
lisp/progmodes/python.el | 250 +++-
lisp/progmodes/ruby-ts-mode.el | 14 +
lisp/progmodes/typescript-ts-mode.el | 362 ++---
lisp/progmodes/vhdl-mode.el | 90 +-
lisp/progmodes/which-func.el | 4 +-
lisp/server.el | 6 +-
lisp/simple.el | 83 +-
lisp/sort.el | 21 +
lisp/speedbar.el | 2 +-
lisp/startup.el | 24 +-
lisp/subr.el | 65 +-
lisp/term/android-win.el | 44 +
lisp/textmodes/html-ts-mode.el | 11 +
lisp/textmodes/pixel-fill.el | 68 +-
lisp/textmodes/reftex-vars.el | 5 +-
lisp/textmodes/rst.el | 8 +-
lisp/textmodes/tex-mode.el | 43 +-
lisp/textmodes/text-mode.el | 2 +-
lisp/textmodes/yaml-ts-mode.el | 5 +-
lisp/thingatpt.el | 44 +-
lisp/touch-screen.el | 2 +-
lisp/transient.el | 1 -
lisp/treesit.el | 156 +-
lisp/url/url-cid.el | 11 +-
lisp/url/url-http.el | 2 +-
lisp/url/url-ldap.el | 10 +-
lisp/url/url-mailto.el | 17 +-
lisp/vc/diff-mode.el | 173 ++-
lisp/vc/vc-git.el | 11 +-
lisp/vc/vc-hooks.el | 5 +-
lisp/vc/vc.el | 15 +-
lisp/vcursor.el | 2 +-
lisp/visual-wrap.el | 10 +-
lisp/winner.el | 3 +-
lisp/woman.el | 3 +-
m4/copy-file-range.m4 | 41 +-
m4/gettime.m4 | 4 +-
m4/gnulib-common.m4 | 76 +-
m4/gnulib-comp.m4 | 6 +-
m4/memset_explicit.m4 | 6 +-
m4/nanosleep.m4 | 6 +-
m4/nstrftime.m4 | 5 +-
m4/string_h.m4 | 3 +-
m4/time_h.m4 | 3 +-
m4/utimens.m4 | 15 +-
m4/utimensat.m4 | 5 +-
nt/cmdproxy.c | 8 +
nt/gnulib-cfg.mk | 1 +
src/alloc.c | 48 +-
src/android.c | 81 +-
src/android.h | 9 +
src/androidfns.c | 106 +-
src/androidselect.c | 20 +-
src/androidterm.c | 4 +-
src/androidvfs.c | 32 +-
src/buffer.c | 64 +-
src/buffer.h | 2 -
src/bytecode.c | 84 +-
src/ccl.c | 7 +-
src/comp.c | 6 +-
src/conf_post.h | 4 +
src/data.c | 58 +-
src/dispextern.h | 10 +
src/doc.c | 58 +-
src/editfns.c | 85 +-
src/emacs.c | 4 -
src/eval.c | 61 +-
src/fileio.c | 10 +-
src/fns.c | 207 +--
src/inotify.c | 10 +
src/keyboard.c | 26 +-
src/lisp.h | 311 ++--
src/lread.c | 498 ++++---
src/macfont.m | 96 +-
src/marker.c | 2 +-
src/minibuf.c | 110 +-
src/pdumper.c | 68 +-
src/pgtkterm.c | 4 +-
src/print.c | 29 +-
src/process.c | 33 +-
src/sfnt.c | 10 +-
src/sfnt.h | 2 +-
src/sfntfont.c | 6 +-
src/term.c | 21 +-
src/textconv.c | 10 +-
src/thread.c | 39 +
src/thread.h | 11 +
src/timefns.c | 12 +-
src/treesit.c | 4 +-
src/verbose.mk.in | 29 +-
src/window.c | 11 +-
src/xdisp.c | 594 +++++---
src/xfaces.c | 35 +-
test/Makefile.in | 4 +
test/infra/Dockerfile.emba | 2 +-
test/lisp/abbrev-tests.el | 4 +-
test/lisp/auth-source-tests.el | 139 +-
test/lisp/completion-preview-tests.el | 15 +
test/lisp/emacs-lisp/bytecomp-tests.el | 16 +
test/lisp/emacs-lisp/cl-generic-tests.el | 14 +
test/lisp/emacs-lisp/edebug-tests.el | 22 +-
test/lisp/emacs-lisp/eieio-tests/eieio-tests.el | 28 +-
test/lisp/emacs-lisp/hierarchy-tests.el | 5 +-
test/lisp/emacs-lisp/macroexp-resources/vk.el | 2 +-
test/lisp/erc/erc-button-tests.el | 3 +-
test/lisp/erc/erc-fill-tests.el | 5 +-
test/lisp/erc/erc-goodies-tests.el | 4 +-
test/lisp/erc/erc-networks-tests.el | 47 +
test/lisp/erc/erc-scenarios-base-renick.el | 8 +-
.../erc/erc-scenarios-base-upstream-recon-znc.el | 46 +
test/lisp/erc/erc-scenarios-misc-commands.el | 90 ++
test/lisp/erc/erc-scenarios-misc.el | 2 +-
test/lisp/erc/erc-stamp-tests.el | 10 +-
test/lisp/erc/erc-tests.el | 81 +-
.../base/upstream-reconnect/znc-severed.eld | 87 ++
test/lisp/erc/resources/commands/amsg-barnet.eld | 54 +
test/lisp/erc/resources/commands/amsg-foonet.eld | 56 +
test/lisp/erc/resources/erc-scenarios-common.el | 5 +-
test/lisp/erc/resources/erc-tests-common.el | 2 +-
test/lisp/eshell/esh-opt-tests.el | 24 +-
test/lisp/eshell/eshell-tests.el | 2 +-
test/lisp/filenotify-tests.el | 53 +-
test/lisp/files-tests.el | 51 +-
test/lisp/info-tests.el | 16 +-
test/lisp/international/mule-tests.el | 4 +-
test/lisp/minibuffer-tests.el | 7 +
test/lisp/net/tramp-archive-tests.el | 4 +-
test/lisp/net/tramp-tests.el | 120 +-
test/lisp/obarray-tests.el | 31 +-
.../progmodes/java-ts-mode-resources/indent.erts | 31 +
test/lisp/progmodes/python-tests.el | 146 +-
test/lisp/thingatpt-tests.el | 9 +
test/src/comp-resources/comp-test-funcs.el | 4 +-
test/src/comp-tests.el | 25 +-
test/src/eval-tests.el | 37 +-
test/src/fns-tests.el | 10 +
test/src/minibuf-tests.el | 14 +-
test/src/treesit-tests.el | 2 +-
346 files changed, 9646 insertions(+), 6271 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index ce7febca851..1a6acecc206 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -3,8 +3,8 @@
((nil . ((tab-width . 8)
(sentence-end-double-space . t)
- (fill-column . 70)
- (emacs-lisp-docstring-fill-column . 65)
+ (fill-column . 72)
+ (emacs-lisp-docstring-fill-column . 72)
(vc-git-annotate-switches . "-w")
(bug-reference-url-format . "https://debbugs.gnu.org/%s";)
(diff-add-log-use-relative-names . t)
@@ -23,6 +23,11 @@
(electric-quote-string . nil)
(indent-tabs-mode . t)
(mode . bug-reference-prog)))
+ (java-mode . ((c-file-style . "GNU")
+ (electric-quote-comment . nil)
+ (electric-quote-string . nil)
+ (indent-tabs-mode . t)
+ (mode . bug-reference-prog)))
(objc-mode . ((c-file-style . "GNU")
(electric-quote-comment . nil)
(electric-quote-string . nil)
@@ -32,7 +37,8 @@
(mode . bug-reference-prog)))
(log-edit-mode . ((log-edit-font-lock-gnu-style . t)
(log-edit-setup-add-author . t)
- (vc-git-log-edit-summary-target-len . 50)))
+ (vc-git-log-edit-summary-target-len . 50)
+ (fill-column . 64)))
(change-log-mode . ((add-log-time-zone-rule . t)
(fill-column . 74)
(mode . bug-reference)))
diff --git a/.mailmap b/.mailmap
index 18e55b0d1e7..c9bdede6c73 100644
--- a/.mailmap
+++ b/.mailmap
@@ -116,6 +116,7 @@ Lars Ingebrigtsen <larsi@gnus.org> <larsi@quimbies.gnus.org>
Lars Ingebrigtsen <larsi@gnus.org> <larsi@stories.gnus.org>
Laurence Warne <laurencewarne@gmail.com>
Lin Sun <lin.sun@zoom.us>
+Liu Hui <liuhui1610@gmail.com> <ilupin@users.noreply.github.com>
Ludovic Courtès <ludo@gnu.org>
Luke Lee <luke.yx.lee@gmail.com>
Martin Rudalics <rudalics@gmx.at>
@@ -129,7 +130,7 @@ Maxim Nikulin <manikulin@gmail.com>
Michael Albinus <michael.albinus@gmx.de> <albinus@detlef>
Michalis V <mvar.40k@gmail.com>
Miha Rihtaršič <miha@kamnitnik.top>
-Morgan J. Smith <Morgan.J.Smith@outlook.com>
+Morgan Smith <Morgan.J.Smith@outlook.com>
Nick Drozd <nicholasdrozd@gmail.com>
Nicolas Petton <nicolas@petton.fr> <petton.nicolas@gmail.com>
Nitish Chandra <nitishchandrachinta@gmail.com>
@@ -146,8 +147,7 @@ Philip Kaludercic <philipk@posteo.net>
Philip Kaludercic <philipk@posteo.net> <philip.kaludercic@fau.de>
Philip Kaludercic <philipk@posteo.net> <philip@icterid>
Philip Kaludercic <philipk@posteo.net> <philip@warpmail.net>
-Philipp Stephani <phst@google.com>
-Philipp Stephani <phst@google.com> Philipp Stephani <p.stephani2@gmail.com>
+Philipp Stephani <p.stephani2@gmail.com>
Phillip Lord <phillip.lord@russet.org.uk> <phillip.lord@newcastle.ac.uk>
Pierre Lorenzon <devel@pollock-nageoire.net>
Pieter van Oostrum <pieter@vanoostrum.org> <pieter-l@vanoostrum.org>
diff --git a/BUGS b/BUGS
index ee473213c89..f23faa7c756 100644
--- a/BUGS
+++ b/BUGS
@@ -21,6 +21,10 @@ If necessary, you can read the manual without an info
program:
cat info/emacs* | more "+/^File: emacs.*, Node: Bugs,"
+If you think you may have found a critical security issue that needs
+to be communicated privately, please contact the GNU Emacs maintainers
+directly. See admin/MAINTAINERS for their contact details.
+
Please first check the file etc/PROBLEMS (e.g. with C-h C-p in Emacs) to
make sure it isn't a known issue.
diff --git a/CONTRIBUTE b/CONTRIBUTE
index 70b9760bb99..bdee16eeab4 100644
--- a/CONTRIBUTE
+++ b/CONTRIBUTE
@@ -115,9 +115,10 @@ mode after hiding the body of each entry.
Doc-strings should be updated together with the code.
-New defcustom's should always have a ':version' tag stating the first
-Emacs version in which they will appear. Likewise with defcustom's
-whose value is changed -- update their ':version' tag.
+New defcustom's and defface's should always have a ':version' tag
+stating the first Emacs version in which they will appear. Likewise
+with defcustom's or defface's whose value is changed -- update their
+':version' tag.
Think about whether your change requires updating the manuals. If you
know it does not, mark the NEWS entry with "---" before the entry. If
@@ -170,9 +171,9 @@ test 'out-of-tree' builds as well, i.e.:
** Commit messages
-Ordinarily, a change you commit should contain a log entry in its
-commit message and should not touch the repository's ChangeLog files.
-Here is an example commit message (indented):
+Ordinarily, a changeset you commit should contain a description of the
+changes in its commit message and should not touch the repository's
+ChangeLog files. Here is an example commit message (indented):
Deactivate shifted region
@@ -184,8 +185,9 @@ Here is an example commit message (indented):
Deactivate the mark.
Occasionally, commit messages are collected and prepended to a
-ChangeLog file, where they can be corrected. It saves time to get
-them right the first time, so here are guidelines for formatting them:
+generated ChangeLog file, where they can be corrected. It saves time
+to get them right the first time, so here are guidelines for
+formatting them:
- Start with a single unindented summary line explaining the change;
do not end this line with a period. If possible, try to keep the
@@ -194,9 +196,10 @@ them right the first time, so here are guidelines for
formatting them:
contexts.
If the summary line starts with a semicolon and a space "; ", the
- commit message will be ignored when generating the ChangeLog file.
- Use this for minor commits that do not need separate ChangeLog
- entries, such as changes in etc/NEWS.
+ commit message will be skipped and not added to the generated
+ ChangeLog file. Use this for minor commits that do not need to be
+ mentioned in the ChangeLog file, such as changes in etc/NEWS, typo
+ fixes, etc.
- After the summary line, there should be an empty line.
@@ -211,8 +214,9 @@ them right the first time, so here are guidelines for
formatting them:
enforced by a commit hook.
- If only a single file is changed, the summary line can be the normal
- file first line (starting with the asterisk). Then there is no
- individual files section.
+ first line of a ChangeLog entry (starting with the asterisk). Then
+ there will be no individual ChangeLog entries beyond the one in the
+ summary line.
- If the commit has more than one author, the commit message should
contain separate lines to mention the other authors, like the
@@ -243,12 +247,12 @@ them right the first time, so here are guidelines for
formatting them:
- Explaining the rationale for a design choice is best done in comments
in the source code. However, sometimes it is useful to describe just
the rationale for a change; that can be done in the commit message
- between the summary line and the file entries.
+ between the summary line and the following ChangeLog entries.
-- Emacs generally follows the GNU coding standards for ChangeLogs: see
- https://www.gnu.org/prep/standards/html_node/Change-Logs.html
- or run 'info "(standards)Change Logs"'. One exception is that
- commits still sometimes quote `like-this' (as the standards used to
+- Emacs follows the GNU coding standards for ChangeLog entries: see
+ https://www.gnu.org/prep/standards/html_node/Change-Logs.html or run
+ 'info "(standards)Change Logs"'. One exception is that commits
+ still sometimes quote `like-this' (as the standards used to
recommend) rather than 'like-this' or ‘like this’ (as they do now),
as `...' is so widely used elsewhere in Emacs.
@@ -261,9 +265,9 @@ them right the first time, so here are guidelines for
formatting them:
in Emacs; that includes spelling and leaving 2 blanks between
sentences.
- They are preserved indefinitely, and have a reasonable chance of
- being read in the future, so it's better that they have good
- presentation.
+ The ChangeLog entries are preserved indefinitely, and have a
+ reasonable chance of being read in the future, so it's better that
+ they have good presentation.
- Use the present tense; describe "what the change does", not "what
the change did".
diff --git a/ChangeLog.3 b/ChangeLog.3
index dc712df43ad..7db4986410d 100644
--- a/ChangeLog.3
+++ b/ChangeLog.3
@@ -137530,7 +137530,7 @@
Bind `enable-local-variables' in `hack-connection-local-variables'
* lisp/files-x.el (hack-connection-local-variables):
- Bind `enable-local-variables', instead of re-declaring
+ Bind `enable-local-variables', instead of redeclaring
`safe-local-variable-p'.
2019-03-23 Eli Zaretskii <eliz@gnu.org>
@@ -163179,7 +163179,7 @@
Quieten compilation of octave.el
- * lisp/progmodes/octave.el (compilation-forget-errors): Re-declare.
+ * lisp/progmodes/octave.el (compilation-forget-errors): Redeclare.
2018-02-28 Glenn Morris <rgm@gnu.org>
diff --git a/GNUmakefile b/GNUmakefile
index 16064672c65..58c0281e895 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -27,6 +27,8 @@
# newly-built Makefile. If the source tree is already configured,
# this file defers to the existing Makefile.
+. :=
+
# If you want non-default build options, or if you want to build in an
# out-of-source tree, you should run 'configure' before running 'make'.
# But run 'autogen.sh' first, if the source was checked out directly
@@ -36,30 +38,30 @@
ifeq (help,$(filter help,$(MAKECMDGOALS)))
help:
- $(info $ NOTE: This is a brief summary of some common make targets.)
- $(info $ For more detailed information, please read the files INSTALL,)
- $(info $ INSTALL.REPO, Makefile or visit this URL:)
- $(info $
https://www.gnu.org/prep/standards/html_node/Standard-Targets.html)
- $(info $ )
- $(info $ make all -- compile and build Emacs)
- $(info $ make install -- install Emacs)
- $(info $ make TAGS -- update tags tables)
- $(info $ make clean -- delete built files but preserve
configuration)
- $(info $ make mostlyclean -- like 'make clean', but leave those
files that)
- $(info $ usually do not need to be recompiled)
- $(info $ make distclean -- delete all build and configuration
files,)
- $(info $ leave only files included in source
distribution)
- $(info $ make maintainer-clean -- delete almost everything that can be
regenerated)
- $(info $ make extraclean -- like maintainer-clean, and also
delete)
- $(info $ backup and autosave files)
- $(info $ make bootstrap -- delete all compiled files to force a
new bootstrap)
- $(info $ from a clean slate, then build in the
normal way)
- $(info $ make uninstall -- remove files installed by 'make
install')
- $(info $ make check -- run the Emacs test suite)
- $(info $ make docs -- generate Emacs documentation in info
format)
- $(info $ make html -- generate documentation in html format)
- $(info $ make ps -- generate documentation in ps format)
- $(info $ make pdf -- generate documentation in pdf format )
+ $(info $.NOTE: This is a brief summary of some common make targets.)
+ $(info $.For more detailed information, please read the files INSTALL,)
+ $(info $.INSTALL.REPO, Makefile or visit this URL:)
+ $(info
$.https://www.gnu.org/prep/standards/html_node/Standard-Targets.html)
+ $(info $.)
+ $(info $.make all -- compile and build Emacs)
+ $(info $.make install -- install Emacs)
+ $(info $.make TAGS -- update tags tables)
+ $(info $.make clean -- delete built files but preserve
configuration)
+ $(info $.make mostlyclean -- like 'make clean', but leave those
files that)
+ $(info $. usually do not need to be recompiled)
+ $(info $.make distclean -- delete all build and configuration
files,)
+ $(info $. leave only files included in source
distribution)
+ $(info $.make maintainer-clean -- delete almost everything that can be
regenerated)
+ $(info $.make extraclean -- like maintainer-clean, and also
delete)
+ $(info $. backup and autosave files)
+ $(info $.make bootstrap -- delete all compiled files to force a
new bootstrap)
+ $(info $. from a clean slate, then build in the
normal way)
+ $(info $.make uninstall -- remove files installed by 'make
install')
+ $(info $.make check -- run the Emacs test suite)
+ $(info $.make docs -- generate Emacs documentation in info
format)
+ $(info $.make html -- generate documentation in html format)
+ $(info $.make ps -- generate documentation in ps format)
+ $(info $.make pdf -- generate documentation in pdf format )
@:
.PHONY: help
diff --git a/admin/CPP-DEFINES b/admin/CPP-DEFINES
index 06986ec8f48..c07fdc487ee 100644
--- a/admin/CPP-DEFINES
+++ b/admin/CPP-DEFINES
@@ -25,6 +25,9 @@ SOLARIS2
USG
USG5_4
HAIKU Compiling on Haiku.
+__ANDROID__ Compiling for the Android operating system.
+__ANDROID_API__ A numerical "API level" indicating the version of
+ Android being compiled for; see http://apilevels.com.
** Distinguishing GUIs **
@@ -35,10 +38,14 @@ NS_IMPL_COCOA Compile support for Cocoa (Apple)
implementation of NS GUI API.
HAVE_X11 Compile support for the X11 GUI.
HAVE_PGTK Compile support for using GTK itself without directly using X
Windows APIs.
HAVE_HAIKU Compile support for the Haiku window system.
-HAVE_X_WINDOWS Compile support for X Window system
- (It looks like, nowadays, if HAVE_X11 is set, HAVE_X_WINDOWS must
- be, and vice versa. At least, this is true for configure, and
- msdos; not sure about nt.)
+HAVE_X_WINDOWS Compile support for X Window system. Equivalent to HAVE_X11.
+HAVE_ANDROID Compiling the Android GUI interface. Enough of this
+ code is compiled for the build machine cross-compiling
+ the Android port to produce an Emacs binary that can
+ run Lisp code in batch mode, for the purpose of running
+ the byte-compiler.
+ANDROID_STUBIFY The Android GUI interface is being compiled for the build
+ machine, as above.
** X Windows features **
HAVE_X11R6 Whether or not the system has X11R6. (Always defined.)
diff --git a/admin/authors.el b/admin/authors.el
index 6c74f4dd7a1..8ea6064423f 100644
--- a/admin/authors.el
+++ b/admin/authors.el
@@ -175,6 +175,9 @@ files.")
("Michalis V" "^mvar")
("Miha Rihtaršič" "Miha Rihtarsic")
("Mikio Nakajima" "Nakajima Mikio")
+ (nil "montag451@laposte\\.net")
+ (nil "na@aisrntairetnraoitn")
+ ("Morgan Smith" "Morgan J\\. Smith")
("Nelson Jose dos Santos Ferreira" "Nelson Ferreira")
("Noah Peart" "noah\\.v\\.peart@gmail\\.com")
("Noorul Islam" "Noorul Islam K M")
diff --git a/admin/codespell/codespell.exclude
b/admin/codespell/codespell.exclude
index 416d79cf131..6413a73701b 100644
--- a/admin/codespell/codespell.exclude
+++ b/admin/codespell/codespell.exclude
@@ -1583,3 +1583,5 @@ VERY VERY LONG STRIN | VERY VERY LONG STRIN
(ert-info ("Joined by bouncer to #chan@foonet, pal persent")
(ert-info ("Joined by bouncer to #chan@barnet, pal persent")
.UE .
+ (0.03 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: See, by good hap,
yonder's my lord; I have sweat to see his honour.")
+ (0.05 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: But, in defence, by
mercy, 'tis most just.")
diff --git a/admin/gitmerge.el b/admin/gitmerge.el
index 7c815c729e5..32d5c3c1bea 100644
--- a/admin/gitmerge.el
+++ b/admin/gitmerge.el
@@ -111,10 +111,10 @@ If nil, the function `gitmerge-default-branch' guesses.")
(defvar gitmerge-mode-font-lock-keywords
`((,gitmerge-log-regexp
- (1 font-lock-warning-face)
- (2 font-lock-constant-face)
- (3 font-lock-builtin-face)
- (4 font-lock-comment-face))))
+ (1 'font-lock-warning-face)
+ (2 'font-lock-constant-face)
+ (3 'font-lock-builtin-face)
+ (4 'font-lock-comment-face))))
(defvar gitmerge--commits nil)
(defvar gitmerge--from nil)
diff --git a/admin/merge-gnulib b/admin/merge-gnulib
index 5246fb14e1e..41531d573b0 100755
--- a/admin/merge-gnulib
+++ b/admin/merge-gnulib
@@ -53,7 +53,7 @@ GNULIB_MODULES='
AVOIDED_MODULES='
access btowc chmod close crypto/af_alg dup fchdir fstat
- iswblank iswctype iswdigit iswxdigit langinfo lock
+ iswblank iswctype iswdigit iswxdigit langinfo localename-unsafe-limited lock
mbrtowc mbsinit memchr mkdir msvc-inval msvc-nothrow nl_langinfo
openat-die opendir pthread-h raise
save-cwd select setenv sigprocmask stat stdarg
diff --git a/admin/notes/kind-communication b/admin/notes/kind-communication
new file mode 100644
index 00000000000..80b2afb27b2
--- /dev/null
+++ b/admin/notes/kind-communication
@@ -0,0 +1,21 @@
+The GNU Project encourages contributions from anyone who wishes to
+advance the development of the GNU system, regardless of gender, race,
+ethnic group, physical appearance, religion, cultural background, and
+any other demographic characteristics, as well as personal political
+views.
+
+People are sometimes discouraged from participating in GNU development
+because of certain patterns of communication that strike them as
+unfriendly, unwelcoming, rejecting, or harsh. This discouragement
+particularly affects members of disprivileged demographics, but it is
+not limited to them. Therefore, we ask all contributors to make a
+conscious effort, in GNU Project discussions, to communicate in ways
+that avoid that outcome — to avoid practices that will predictably and
+unnecessarily risk putting some contributors off.
+
+The GNU Kind Communications Guidelines suggest specific ways to
+accomplish that goal. You can find the latest version at
+https://www.gnu.org/philosophy/kind-communication.html
+
+When sending messages to Emacs mailing lists, we ask you to read and
+respect these guidelines.
diff --git a/admin/notes/tree-sitter/build-module/build.sh
b/admin/notes/tree-sitter/build-module/build.sh
index 969187b7f92..9a567bb094d 100755
--- a/admin/notes/tree-sitter/build-module/build.sh
+++ b/admin/notes/tree-sitter/build-module/build.sh
@@ -43,7 +43,7 @@ case "${lang}" in
org="phoenixframework"
;;
"lua")
- org="MunifTanjim"
+ org="tree-sitter-grammars"
;;
"typescript")
sourcedir="tree-sitter-typescript/typescript/src"
diff --git a/configure.ac b/configure.ac
index fa8b04ec685..452aa0838f1 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1231,6 +1231,7 @@ package will likely install on older systems but crash on
startup.])
passthrough="$passthrough --with-mailutils=$with_mailutils"
passthrough="$passthrough --with-pop=$with_pop"
passthrough="$passthrough --with-harfbuzz=$with_harfbuzz"
+ passthrough="$passthrough --with-threads=$with_threads"
# Now pass through some checking options.
emacs_val="--enable-check-lisp-object-type=$enable_check_lisp_object_type"
@@ -1321,6 +1322,7 @@ if test "$ANDROID" = "yes"; then
with_pop=no
with_harfbuzz=no
with_native_compilation=no
+ with_threads=no
fi
with_rsvg=no
@@ -1331,7 +1333,6 @@ if test "$ANDROID" = "yes"; then
with_gpm=no
with_dbus=no
with_gsettings=no
- with_threads=no
with_ns=no
# zlib is available in android.
@@ -2336,6 +2337,7 @@ fi
AC_DEFUN([AC_TYPE_SIZE_T])
# Likewise for obsolescent test for uid_t, gid_t; Emacs assumes them.
AC_DEFUN([AC_TYPE_UID_T])
+ac_cv_type_gid_t=yes # AC_TYPE_GETGROUPS needs this in Autoconf 2.72.
# Check for all math.h functions that Emacs uses; on some platforms,
# -lm is needed for some of these functions.
@@ -4086,16 +4088,16 @@ case $with_file_notification,$opsys in
fi ;;
esac
-dnl inotify is available only on GNU/Linux.
+dnl inotify is available only on Linux-kernel based systems.
case $with_file_notification,$NOTIFY_OBJ in
inotify, | yes,)
AC_CHECK_HEADER([sys/inotify.h])
if test "$ac_cv_header_sys_inotify_h" = yes ; then
- AC_CHECK_FUNC([inotify_init1])
- if test "$ac_cv_func_inotify_init1" = yes; then
+ AC_CHECK_FUNCS([inotify_init inotify_init1])
+ if test "$ac_cv_func_inotify_init" = yes; then
AC_DEFINE([HAVE_INOTIFY], [1], [Define to 1 to use inotify.])
NOTIFY_OBJ=inotify.o
- NOTIFY_SUMMARY="yes -lglibc (inotify)"
+ NOTIFY_SUMMARY="yes (inotify)"
fi
fi ;;
esac
@@ -5905,13 +5907,15 @@ pthread_sigmask strsignal setitimer \
sendto recvfrom getsockname getifaddrs freeifaddrs \
gai_strerror sync \
endpwent getgrent endgrent \
-renameat2 \
cfmakeraw cfsetspeed __executable_start log2 pthread_setname_np \
pthread_set_name_np])
# getpwent is not present in older versions of Android. (bug#65319)
gl_CHECK_FUNCS_ANDROID([getpwent], [[#include <pwd.h>]])
+# renameat2 is not present in older versions of Android.
+gl_CHECK_FUNCS_ANDROID([renameat2], [[#include <stdio.h>]])
+
if test "$ac_cv_func_cfmakeraw" != "yes"; then
# On some systems (Android), cfmakeraw is inline, so AC_CHECK_FUNCS
# cannot find it. Check if some code including termios.h and using
diff --git a/cross/verbose.mk.android b/cross/verbose.mk.android
index 958cf237c58..7b9af76404b 100644
--- a/cross/verbose.mk.android
+++ b/cross/verbose.mk.android
@@ -44,12 +44,13 @@ have_working_info = $(filter notintermediate,$(value
.FEATURES))
# The workaround is done only for AM_V_ELC and AM_V_ELN,
# since the bug is not annoying elsewhere.
-AM_V_AR = @$(info $ AR $@)
+. :=
+AM_V_AR = @$(info $. AR $@)
AM_V_at = @
-AM_V_CC = @$(info $ CC $@)
-AM_V_CXX = @$(info $ CXX $@)
-AM_V_CCLD = @$(info $ CCLD $@)
-AM_V_CXXLD = @$(info $ CXXLD $@)
-AM_V_GEN = @$(info $ GEN $@)
+AM_V_CC = @$(info $. CC $@)
+AM_V_CXX = @$(info $. CXX $@)
+AM_V_CCLD = @$(info $. CCLD $@)
+AM_V_CXXLD = @$(info $. CXXLD $@)
+AM_V_GEN = @$(info $. GEN $@)
AM_V_NO_PD = --no-print-directory
endif
diff --git a/doc/emacs/basic.texi b/doc/emacs/basic.texi
index cdc183c2a40..b1b1573729a 100644
--- a/doc/emacs/basic.texi
+++ b/doc/emacs/basic.texi
@@ -632,15 +632,18 @@ long, by using Auto Fill mode. @xref{Filling}.
@cindex continuation lines, visual wrap prefix
@findex visual-wrap-prefix-mode
+@findex global-visual-wrap-prefix-mode
Normally, the first character of each continuation line is
positioned at the beginning of the screen line where it is displayed.
-The minor mode @code{visual-wrap-prefix-mode} arranges that
-continuation lines be prefixed by slightly adjusted versions of the
-fill prefixes (@pxref{Fill Prefix}) of their respective logical lines,
-so that indentation characters or the prefixes of source code comments
-are replicated across every continuation line, and the appearance of
-such comments or indentation is not broken. These prefixes are only
-shown on display, and does not change the buffer text in any way.
+The minor mode @code{visual-wrap-prefix-mode} and its global
+(@pxref{Minor Modes}) counterpart
+@code{global-visual-wrap-prefix-mode} arranges that continuation lines
+be prefixed by slightly adjusted versions of the fill prefixes
+(@pxref{Fill Prefix}) of their respective logical lines, so that
+indentation characters or the prefixes of source code comments are
+replicated across every continuation line, and the appearance of such
+comments or indentation is not broken. These prefixes are only shown
+on display, and does not change the buffer text in any way.
Sometimes, you may need to edit files containing many long logical
lines, and it may not be practical to break them all up by adding
diff --git a/doc/emacs/buffers.texi b/doc/emacs/buffers.texi
index d9113a6811a..00160afd844 100644
--- a/doc/emacs/buffers.texi
+++ b/doc/emacs/buffers.texi
@@ -205,7 +205,7 @@ Here is an example of a buffer list:
@smallexample
CRM Buffer Size Mode File
-. * .emacs 3294 Emacs-Lisp ~/.emacs
+. * .emacs 3294 ELisp/l ~/.emacs
% *Help* 101 Help
search.c 86055 C ~/cvs/emacs/src/search.c
% src 20959 Dired by name ~/cvs/emacs/src/
diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi
index 6db9e8344c6..bda57d2b30e 100644
--- a/doc/emacs/display.texi
+++ b/doc/emacs/display.texi
@@ -2210,6 +2210,14 @@ keys; its value is the number of seconds of pause
required to cause echoing
to start, or zero, meaning don't echo at all. The value takes effect when
there is something to echo. @xref{Echo Area}.
+@vindex echo-keystrokes-help
+ If the variable @code{echo-keystrokes-help} is non-@code{nil} (the
+default), the multi-character key sequence echo shown according to
+@code{echo-keystrokes} will include a short help text about keys which
+will invoke @code{describe-prefix-bindings} (@pxref{Misc Help}) to show
+the list of commands for the prefix you already typed. For a related
+help facility, see @ref{which-key}.
+
@cindex mouse pointer
@cindex hourglass pointer display
@vindex display-hourglass
diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi
index 99a4173ac29..05457a3f34f 100644
--- a/doc/emacs/help.texi
+++ b/doc/emacs/help.texi
@@ -260,6 +260,11 @@ by these buttons, Emacs provides the
@code{button-describe} and
@code{widget-describe} commands, that should be run with point over
the button.
+@anchor{which-key}
+@kbd{M-x which-key} is a global minor mode which helps in discovering
+ keymaps. It displays keybindings following your currently entered
+ incomplete command (prefix), in a popup.
+
@node Name Help
@section Help by Command or Variable Name
diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi
index 338bf014208..cb347d59948 100644
--- a/doc/emacs/text.texi
+++ b/doc/emacs/text.texi
@@ -1097,6 +1097,12 @@ so that Outline mode will know that sections are
contained in
chapters. This works as long as no other command starts with
@samp{@@chap}.
+@vindex outline-search-function
+ Instead of setting the variable @code{outline-regexp}, you can set
+the variable @code{outline-search-function} to a function that
+matches the current heading and searches for the next one
+(@pxref{Outline Minor Mode,,,elisp, the Emacs Lisp Reference Manual}).
+
@vindex outline-level
You can explicitly specify a rule for calculating the level of a
heading line by setting the variable @code{outline-level}. The value
diff --git a/doc/lispref/abbrevs.texi b/doc/lispref/abbrevs.texi
index 9b719145584..d89cec4bc2b 100644
--- a/doc/lispref/abbrevs.texi
+++ b/doc/lispref/abbrevs.texi
@@ -65,7 +65,7 @@ expanded in the buffer. For the user-level commands for
abbrevs, see
@defun make-abbrev-table &optional props
This function creates and returns a new, empty abbrev table---an
-obarray containing no symbols. It is a vector filled with zeros.
+obarray containing no symbols.
@var{props} is a property list that is applied to the new table
(@pxref{Abbrev Table Properties}).
@end defun
diff --git a/doc/lispref/compile.texi b/doc/lispref/compile.texi
index 98a01fb67f9..00602198da5 100644
--- a/doc/lispref/compile.texi
+++ b/doc/lispref/compile.texi
@@ -35,7 +35,6 @@ variable binding for @code{no-byte-compile} into it, like
this:
* Speed of Byte-Code:: An example of speedup from byte compilation.
* Compilation Functions:: Byte compilation functions.
* Docs and Compilation:: Dynamic loading of documentation strings.
-* Dynamic Loading:: Dynamic loading of individual functions.
* Eval During Compile:: Code to be evaluated when you compile.
* Compiler Errors:: Handling compiler error messages.
* Byte-Code Objects:: The data type used for byte-compiled functions.
@@ -289,71 +288,6 @@ stands for the name of this file, as a string. Do not use
these
constructs in Lisp source files; they are not designed to be clear to
humans reading the file.
-@node Dynamic Loading
-@section Dynamic Loading of Individual Functions
-
-@cindex dynamic loading of functions
-@cindex lazy loading
- When you compile a file, you can optionally enable the @dfn{dynamic
-function loading} feature (also known as @dfn{lazy loading}). With
-dynamic function loading, loading the file doesn't fully read the
-function definitions in the file. Instead, each function definition
-contains a place-holder which refers to the file. The first time each
-function is called, it reads the full definition from the file, to
-replace the place-holder.
-
- The advantage of dynamic function loading is that loading the file
-should become faster. This is a good thing for a file which contains
-many separate user-callable functions, if using one of them does not
-imply you will probably also use the rest. A specialized mode which
-provides many keyboard commands often has that usage pattern: a user may
-invoke the mode, but use only a few of the commands it provides.
-
- The dynamic loading feature has certain disadvantages:
-
-@itemize @bullet
-@item
-If you delete or move the compiled file after loading it, Emacs can no
-longer load the remaining function definitions not already loaded.
-
-@item
-If you alter the compiled file (such as by compiling a new version),
-then trying to load any function not already loaded will usually yield
-nonsense results.
-@end itemize
-
- These problems will never happen in normal circumstances with
-installed Emacs files. But they are quite likely to happen with Lisp
-files that you are changing. The easiest way to prevent these problems
-is to reload the new compiled file immediately after each recompilation.
-
- @emph{Experience shows that using dynamic function loading provides
-benefits that are hardly measurable, so this feature is deprecated
-since Emacs 27.1.}
-
- The byte compiler uses the dynamic function loading feature if the
-variable @code{byte-compile-dynamic} is non-@code{nil} at compilation
-time. Do not set this variable globally, since dynamic loading is
-desirable only for certain files. Instead, enable the feature for
-specific source files with file-local variable bindings. For example,
-you could do it by writing this text in the source file's first line:
-
-@example
--*-byte-compile-dynamic: t;-*-
-@end example
-
-@defvar byte-compile-dynamic
-If this is non-@code{nil}, the byte compiler generates compiled files
-that are set up for dynamic function loading.
-@end defvar
-
-@defun fetch-bytecode function
-If @var{function} is a byte-code function object, this immediately
-finishes loading the byte code of @var{function} from its
-byte-compiled file, if it is not fully loaded already. Otherwise,
-it does nothing. It always returns @var{function}.
-@end defun
-
@node Eval During Compile
@section Evaluation During Compilation
@cindex eval during compilation
diff --git a/doc/lispref/control.texi b/doc/lispref/control.texi
index 0c6895332a0..78ad5b68a51 100644
--- a/doc/lispref/control.texi
+++ b/doc/lispref/control.texi
@@ -638,6 +638,16 @@ with @var{n} arguments (the other elements) and an
additional
Example: @code{(= 42)}@*
In this example, the function is @code{=}, @var{n} is one, and
the actual function call becomes: @w{@code{(= 42 @var{expval})}}.
+
+@item function call with an @code{_} arg
+Call the function (the first element of the function call)
+with the specified arguments (the other elements) and replacing
+@code{_} with @var{expval}.
+
+Example: @code{(gethash _ memo-table)}
+In this example, the function is @code{gethash}, and
+the actual function call becomes: @w{@code{(gethash @var{expval}
+memo-table)}}.
@end table
@item (app @var{function} @var{pattern})
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index a3ef8313f8e..ed254795d90 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -653,7 +653,6 @@ Byte Compilation
* Speed of Byte-Code:: An example of speedup from byte compilation.
* Compilation Functions:: Byte compilation functions.
* Docs and Compilation:: Dynamic loading of documentation strings.
-* Dynamic Loading:: Dynamic loading of individual functions.
* Eval During Compile:: Code to be evaluated when you compile.
* Compiler Errors:: Handling compiler error messages.
* Byte-Code Objects:: The data type used for byte-compiled functions.
@@ -884,6 +883,7 @@ Major and Minor Modes
* Minor Modes:: Defining minor modes.
* Mode Line Format:: Customizing the text that appears in the mode line.
* Imenu:: Providing a menu of definitions made in a buffer.
+* Outline Minor Mode:: Outline mode to use with other major modes.
* Font Lock Mode:: How modes can highlight text according to syntax.
* Auto-Indentation:: How to teach Emacs to indent for a major mode.
* Desktop Save Mode:: How modes can have buffer state saved between
diff --git a/doc/lispref/intro.texi b/doc/lispref/intro.texi
index 2062ae64866..486125acb0d 100644
--- a/doc/lispref/intro.texi
+++ b/doc/lispref/intro.texi
@@ -89,9 +89,9 @@ you are criticizing.
@cindex bugs
@cindex suggestions
-Please send comments and corrections using @kbd{M-x
-report-emacs-bug}. If you wish to contribute new code (or send a
-patch to fix a problem), use @kbd{M-x submit-emacs-patch}.
+Please send comments and corrections using @kbd{M-x report-emacs-bug}.
+For more details, @xref{Bugs,, Reporting Bugs, emacs, The GNU Emacs
+Manual}.
@node Lisp History
@section Lisp History
diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi
index aa27de72ba0..0247c93f7b8 100644
--- a/doc/lispref/minibuf.texi
+++ b/doc/lispref/minibuf.texi
@@ -2562,6 +2562,14 @@ times match.
The optional argument @var{default} specifies the default password to
return if the user enters empty input. If @var{default} is @code{nil},
then @code{read-passwd} returns the null string in that case.
+
+This function uses @code{read-passwd-mode}, a minor mode. It binds two
+keys in the minbuffer: @kbd{C-u} (@code{delete-minibuffer-contents})
+deletes the password, and @kbd{TAB}
+(@code{read-passwd--toggle-visibility}) toggles the visibility of the
+password. There is also an additional icon in the mode-line. Clicking
+on this icon with @key{mouse-1} toggles the visibility of the password
+as well.
@end defun
@node Minibuffer Commands
diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi
index 1d961249633..630e42e6878 100644
--- a/doc/lispref/modes.texi
+++ b/doc/lispref/modes.texi
@@ -25,6 +25,7 @@ user. For related topics such as keymaps and syntax tables,
see
* Minor Modes:: Defining minor modes.
* Mode Line Format:: Customizing the text that appears in the mode line.
* Imenu:: Providing a menu of definitions made in a buffer.
+* Outline Minor Mode:: Outline mode to use with other major modes.
* Font Lock Mode:: How modes can highlight text according to syntax.
* Auto-Indentation:: How to teach Emacs to indent for a major mode.
* Desktop Save Mode:: How modes can have buffer state saved between
@@ -507,6 +508,12 @@ variable @code{imenu-generic-expression}, for the two
variables
@code{imenu-extract-index-name-function}, or for the variable
@code{imenu-create-index-function} (@pxref{Imenu}).
+@item
+The mode should specify how Outline minor mode should find the
+heading lines, by setting up a buffer-local value for the variables
+@code{outline-regexp} or @code{outline-search-function}, and also
+for the variable @code{outline-level} (@pxref{Outline Minor Mode}).
+
@item
The mode can tell ElDoc mode how to retrieve different types of
documentation for whatever is at point, by adding one or more
@@ -1182,7 +1189,7 @@ column is sorted in the descending order.
This buffer-local variable specifies the format of the Tabulated List
data. Its value should be a vector. Each element of the vector
represents a data column, and should be a list @code{(@var{name}
-@var{width} @var{sort})}, where
+@var{width} @var{sort} . @var{props})}, where
@itemize
@item
@@ -1199,6 +1206,13 @@ sorted by comparing string values. Otherwise, this
should be a
predicate function for @code{sort} (@pxref{Rearrangement}), which
accepts two arguments with the same form as the elements of
@code{tabulated-list-entries} (see below).
+
+@item
+@var{props} is a plist (@pxref{Property Lists}) of additional column
+properties. If the value of the property @code{:right-align} is
+non-@code{nil} then the column should be right-aligned. And the
+property @code{:pad-right} specifies the number of additional padding
+spaces to the right of the column (by default 1 if omitted).
@end itemize
@end defvar
@@ -2994,6 +3008,61 @@ instead.
automatically sets up Imenu if this variable is non-@code{nil}.
@end defvar
+@node Outline Minor Mode
+@section Outline Minor Mode
+
+@cindex Outline minor mode
+ @dfn{Outline minor mode} is a buffer-local minor mode that hides
+parts of the buffer and leaves only heading lines visible.
+This minor mode can be used in conjunction with other major modes
+(@pxref{Outline Minor Mode,, Outline Minor Mode, emacs, the Emacs Manual}).
+
+ There are two ways to define which lines are headings: with the
+variable @code{outline-regexp} or @code{outline-search-function}.
+
+@defvar outline-regexp
+This variable is a regular expression.
+Any line whose beginning has a match for this regexp is considered a
+heading line. Matches that start within a line (not at the left
+margin) do not count.
+@end defvar
+
+@defvar outline-search-function
+Alternatively, when it's impossible to create a regexp that
+matches heading lines, you can define a function that helps
+Outline minor mode to find heading lines.
+
+The variable @code{outline-search-function} specifies the function with
+four arguments: @var{bound}, @var{move}, @var{backward}, and
+@var{looking-at}. The function completes two tasks: to match the
+current heading line, and to find the next or the previous heading line.
+If the argument @var{looking-at} is non-@code{nil}, it should return
+non-@code{nil} when point is at the beginning of the outline header line.
+If the argument @var{looking-at} is @code{nil}, the first three arguments
+are used. The argument @var{bound} is a buffer position that bounds
+the search. The match found must not end after that position. A
+value of nil means search to the end of the accessible portion of
+the buffer. If the argument @var{move} is non-@code{nil}, the
+failed search should move to the limit of search and return nil.
+If the argument @var{backward} is non-@code{nil}, this function
+should search for the previous heading backward.
+@end defvar
+
+@defvar outline-level
+This variable is a function that takes no arguments
+and should return the level of the current heading.
+It's required in both cases: whether you define
+@code{outline-regexp} or @code{outline-search-function}.
+@end defvar
+
+If built with tree-sitter, Emacs can automatically use
+Outline minor mode if the major mode sets the following variable.
+
+@defvar treesit-outline-predicate
+This variable instructs Emacs how to find lines with outline headings.
+It should be a predicate that matches the node on the heading line.
+@end defvar
+
@node Font Lock Mode
@section Font Lock Mode
@cindex Font Lock mode
diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi
index 18484bac368..01f82d56528 100644
--- a/doc/lispref/objects.texi
+++ b/doc/lispref/objects.texi
@@ -2122,6 +2122,9 @@ with references to further information.
@item numberp
@xref{Predicates on Numbers, numberp}.
+@item obarrayp
+@xref{Creating Symbols, obarrayp}.
+
@item overlayp
@xref{Overlays, overlayp}.
@@ -2182,7 +2185,7 @@ This function returns a symbol naming the primitive type
of
@code{condition-variable}, @code{cons}, @code{finalizer},
@code{float}, @code{font-entity}, @code{font-object},
@code{font-spec}, @code{frame}, @code{hash-table}, @code{integer},
-@code{marker}, @code{mutex}, @code{overlay}, @code{process},
+@code{marker}, @code{mutex}, @code{obarray}, @code{overlay}, @code{process},
@code{string}, @code{subr}, @code{symbol}, @code{thread},
@code{vector}, @code{window}, or @code{window-configuration}.
However, if @var{object} is a record, the type specified by its first
diff --git a/doc/lispref/package.texi b/doc/lispref/package.texi
index f75023d4039..421e64dd5d1 100644
--- a/doc/lispref/package.texi
+++ b/doc/lispref/package.texi
@@ -28,6 +28,7 @@ these archives).
* Multi-file Packages:: How to package multiple files.
* Package Archives:: Maintaining package archives.
* Archive Web Server:: Interfacing to an archive web server.
+* Forwards-Compatibility:: Supporting older versions of Emacs.
@end menu
@node Packaging Basics
@@ -399,3 +400,50 @@ Return the file. This will be the tarball for a multi-file
package, or the single file for a simple package.
@end table
+
+@node Forwards-Compatibility
+@section Supporting older versions of Emacs
+@cindex compatibility compat
+
+Packages that wish to support older releases of Emacs, without giving
+up on newer functionality from recent Emacs releases, one can make use
+of the Compat package on GNU ELPA. By depending on the package, Emacs
+can provide compatibility definitions for missing functionality.
+
+The versioning of Compat follows that of Emacs, so next to the oldest
+version that a package relies on (via the @code{emacs}-package), one
+can also indicate what the newest version of Emacs is, that a package
+wishes to use definitions from:
+
+@example
+;; Package-Requires: ((emacs "27.2") (compat "29.1"))
+@end example
+
+Note that Compat provides replacement functions with extended
+functionality for functions that are already defined (@code{sort},
+@code{assoc}, @dots{}). These functions may have changed their
+calling convention (additional optional arguments) or may have changed
+their behavior. These functions must be looked up explicitly with
+@code{compat-function} or called explicitly with @code{compat-call}.
+We call them @dfn{Extended Definitions}. In contrast, newly @dfn{Added
+Definitions} can be called as usual.
+
+@defmac compat-call fun &rest args
+This macro calls the compatibility function @var{fun} with @var{args}.
+Many functions provided by Compat can be called directly without this
+macro. However in the case where Compat provides an alternative
+version of an existing function, the function call has to go through
+@code{compat-call}.
+@end defmac
+
+@defmac compat-function fun
+This macro returns the compatibility function symbol for @var{fun}.
+See @code{compat-call} for a more convenient macro to directly call
+compatibility functions.
+@end defmac
+
+For further details on how to make use of the package, see
+@ref{Usage,, Usage, compat, "Compat" Manual}. In case you don't have
+the manual installed, you can also read the
+@url{https://elpa.gnu.org/packages/doc/compat.html#Usage, Online
+Compat manual}.
diff --git a/doc/lispref/parsing.texi b/doc/lispref/parsing.texi
index 5d79c4b27f4..3d2192ace64 100644
--- a/doc/lispref/parsing.texi
+++ b/doc/lispref/parsing.texi
@@ -794,7 +794,7 @@ that comes after it in the buffer position order, i.e.,
nodes with
start positions greater than the end position of @var{start}.
In the tree shown above, @code{treesit-search-subtree} traverses node
-@samp{S} (@var{start}) and nodes marked with @code{o}, where this
+@samp{S} (@var{start}) and nodes marked with @code{o}, whereas this
function traverses the nodes marked with numbers. This function is
useful for answering questions like ``what is the first node after
@var{start} in the buffer that satisfies some condition?''
@@ -916,32 +916,37 @@ nodes.
@defun treesit-parent-until node predicate &optional include-node
This function repeatedly finds the parents of @var{node}, and returns
-the parent that satisfies @var{pred}, a function that takes a node as
-argument and returns a boolean that indicates a match. If no parent
-satisfies @var{pred}, this function returns @code{nil}.
+the parent that satisfies @var{predicate}. @var{predicate} can be
+either a function that takes a node as argument and returns @code{t}
+or @code{nil}, or a regexp matching node type names, or other valid
+predicates described in @var{treesit-thing-settings}. If no parent
+satisfies @var{predicates}, this function returns @code{nil}.
Normally this function only looks at the parents of @var{node} but not
@var{node} itself. But if @var{include-node} is non-@code{nil}, this
-function returns @var{node} if @var{node} satisfies @var{pred}.
+function returns @var{node} if @var{node} satisfies @var{predicate}.
@end defun
-@defun treesit-parent-while node pred
+@defun treesit-parent-while node predicate
This function goes up the tree starting from @var{node}, and keeps
-doing so as long as the nodes satisfy @var{pred}, a function that
+doing so as long as the nodes satisfy @var{predicate}, a function that
takes a node as argument. That is, this function returns the highest
-parent of @var{node} that still satisfies @var{pred}. Note that if
-@var{node} satisfies @var{pred} but its immediate parent doesn't,
+parent of @var{node} that still satisfies @var{predicate}. Note that if
+@var{node} satisfies @var{predicate} but its immediate parent doesn't,
@var{node} itself is returned.
@end defun
-@defun treesit-node-top-level node &optional type
+@defun treesit-node-top-level node &optional predicate include-node
This function returns the highest parent of @var{node} that has the
same type as @var{node}. If no such parent exists, it returns
@code{nil}. Therefore this function is also useful for testing
whether @var{node} is top-level.
-If @var{type} is non-@code{nil}, this function matches each parent's
-type with @var{type} as a regexp, rather than using @var{node}'s type.
+If @var{predicate} is @code{nil}, this function uses @var{node}'s type
+to find the parent. If @var{predicate} is non-@code{nil}, this
+function searches the parent that satisfies @var{predicate}. If
+@var{include-node} is non-@code{nil}, this function returns @var{node}
+if @var{node} satisfies @var{predicate}.
@end defun
@node Accessing Node Information
@@ -1892,6 +1897,10 @@ add-log functions used by @code{add-log-current-defun}.
@item
If @code{treesit-simple-imenu-settings} (@pxref{Imenu}) is
non-@code{nil}, it sets up Imenu.
+
+@item
+If @code{treesit-outline-predicate} (@pxref{Outline Minor Mode}) is
+non-@code{nil}, it sets up Outline minor mode.
@end itemize
@c TODO: Add treesit-thing-settings stuff once we finalize it.
diff --git a/doc/lispref/sequences.texi b/doc/lispref/sequences.texi
index f1f23f007a4..74719d4779f 100644
--- a/doc/lispref/sequences.texi
+++ b/doc/lispref/sequences.texi
@@ -434,12 +434,44 @@ but their relative order is also preserved:
(9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")]
@end group
@end example
-
-@xref{Sorting}, for more functions that perform sorting.
-See @code{documentation} in @ref{Accessing Documentation}, for a
-useful example of @code{sort}.
@end defun
+Sometimes, computation of sort keys of list or vector elements is
+expensive, and therefore it is important to perform it the minimum
+number of times. By contrast, computing the sort keys of elements
+inside the @var{predicate} function passed to @code{sort} will generally
+perform this computation each time @var{predicate} is called with some
+element. If you can separate the computation of the sort key of an
+element into a function of its own, you can use the following sorting
+function, which guarantees that the key will be computed for each list
+or vector element exactly once.
+
+@cindex decorate-sort-undecorate
+@cindex Schwartzian transform
+@defun sort-on sequence predicate accessor
+This function stably sorts @var{sequence}, which can be a list, a
+vector, a bool-vector, or a string. It sorts by comparing the sort
+keys of the elements using @var{predicate}. The comparison function
+@var{predicate} accepts two arguments, the sort keys to compare, and
+should return non-@code{nil} if the element corresponding to the first
+key should sort before the element corresponding to the second key. The
+function computes a sort key of each element by calling the
+@var{accessor} function on that element; it does so exactly once for
+each element of @var{sequence}. The @var{accessor} function is called
+with a single argument, an element of @var{sequence}.
+
+This function implements what is known as @dfn{decorate-sort-undecorate}
+paradigm, or the Schwartzian transform. It basically trades CPU for
+memory, creating a temporary list with the computed sort keys, then
+mapping @code{car} over the result of sorting that temporary list.
+Unlike with @code{sort}, the return value is always a new list; the
+original @var{sequence} is left intact.
+@end defun
+
+@xref{Sorting}, for more functions that perform sorting. See
+@code{documentation} in @ref{Accessing Documentation}, for a useful
+example of @code{sort}.
+
@cindex sequence functions in seq
@cindex seq library
@cindex sequences, generalized
diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi
index 367bd195f16..5207ea4ea7b 100644
--- a/doc/lispref/symbols.texi
+++ b/doc/lispref/symbols.texi
@@ -177,34 +177,16 @@ know how Lisp reads them. Lisp must ensure that it finds
the same
symbol every time it reads the same sequence of characters in the same
context. Failure to do so would cause complete confusion.
-@cindex symbol name hashing
-@cindex hashing
@cindex obarray
-@cindex bucket (in obarray)
When the Lisp reader encounters a name that references a symbol in
-the source code, it reads all the characters of that name. Then it
-looks up that name in a table called an @dfn{obarray} to find the
-symbol that the programmer meant. The technique used in this lookup
-is called ``hashing'', an efficient method of looking something up by
-converting a sequence of characters to a number, known as a ``hash
-code''. For example, instead of searching a telephone book cover to
-cover when looking up Jan Jones, you start with the J's and go from
-there. That is a simple version of hashing. Each element of the
-obarray is a @dfn{bucket} which holds all the symbols with a given
-hash code; to look for a given name, it is sufficient to look through
-all the symbols in the bucket for that name's hash code. (The same
-idea is used for general Emacs hash tables, but they are a different
-data type; see @ref{Hash Tables}.)
-
-When looking up names, the Lisp reader also considers ``shorthands''.
+the source code, it looks up that name in a table called an @dfn{obarray}
+to find the symbol that the programmer meant. An obarray is an unordered
+container of symbols, indexed by name.
+
+The Lisp reader also considers ``shorthands''.
If the programmer supplied them, this allows the reader to find a
symbol even if its name isn't present in its full form in the source
-code. Of course, the reader needs to be aware of some pre-established
-context about such shorthands, much as one needs context to be to able
-to refer uniquely to Jan Jones by just the name ``Jan'': it's probably
-fine when amongst the Joneses, or when Jan has been mentioned
-recently, but very ambiguous in any other situation.
-@xref{Shorthands}.
+code. @xref{Shorthands}.
@cindex interning
If a symbol with the desired name is found, the reader uses that
@@ -236,23 +218,6 @@ to gain access to it is by finding it in some other object
or as the
value of a variable. Uninterned symbols are sometimes useful in
generating Lisp code, see below.
- In Emacs Lisp, an obarray is actually a vector. Each element of the
-vector is a bucket; its value is either an interned symbol whose name
-hashes to that bucket, or 0 if the bucket is empty. Each interned
-symbol has an internal link (invisible to the user) to the next symbol
-in the bucket. Because these links are invisible, there is no way to
-find all the symbols in an obarray except using @code{mapatoms} (below).
-The order of symbols in a bucket is not significant.
-
- In an empty obarray, every element is 0, so you can create an obarray
-with @code{(make-vector @var{length} 0)}. @strong{This is the only
-valid way to create an obarray.} Prime numbers as lengths tend
-to result in good hashing; lengths one less than a power of two are also
-good.
-
- @strong{Do not try to put symbols in an obarray yourself.} This does
-not work---only @code{intern} can enter a symbol in an obarray properly.
-
@cindex CL note---symbol in obarrays
@quotation
@b{Common Lisp note:} Unlike Common Lisp, Emacs Lisp does not provide
@@ -262,9 +227,21 @@ Emacs Lisp provides a different namespacing system called
``shorthands'' (@pxref{Shorthands}).
@end quotation
+@defun obarray-make &optional size
+This function creates and returns a new obarray.
+The optional @var{size} may be used to specify the number of symbols
+that it is expected to hold, but since obarrays grow automatically
+as needed, this rarely provide any benefit.
+@end defun
+
+@defun obarrayp object
+This function returns @code{t} if @var{object} is an obarray,
+@code{nil} otherwise.
+@end defun
+
Most of the functions below take a name and sometimes an obarray as
arguments. A @code{wrong-type-argument} error is signaled if the name
-is not a string, or if the obarray is not a vector.
+is not a string, or if the obarray is not an obarray object.
@defun symbol-name symbol
This function returns the string that is @var{symbol}'s name. For example:
@@ -416,6 +393,10 @@ If @code{unintern} does delete a symbol, it returns
@code{t}. Otherwise
it returns @code{nil}.
@end defun
+@defun obarray-clear obarray
+This function removes all symbols from @var{obarray}.
+@end defun
+
@node Symbol Properties
@section Symbol Properties
@cindex symbol property
@@ -761,6 +742,23 @@ instead of @code{snu-}.
;; End:
@end example
+Note that if you have two shorthands in the same file where one is the
+prefix of the other, the longer shorthand will be attempted first.
+This happens regardless of the order you specify shorthands in the
+local variables section of your file.
+
+@example
+'(
+ t//foo ; reads to 'my-tricks--foo', not 'my-tricks-/foo'
+ t/foo ; reads to 'my-tricks-foo'
+ )
+
+;; Local Variables:
+;; read-symbol-shorthands: (("t/" . "my-tricks-")
+;; ("t//" . "my-tricks--")
+;; End:
+@end example
+
@subsection Exceptions
There are two exceptions to rules governing Shorthand transformations:
diff --git a/doc/misc/epa.texi b/doc/misc/epa.texi
index 27a9e2b0ebb..f450b9cbdd9 100644
--- a/doc/misc/epa.texi
+++ b/doc/misc/epa.texi
@@ -289,6 +289,15 @@ also ask you whether or not to sign the text before
encryption and if
you answered yes, it will let you select the signing keys.
@end deffn
+@defvar epa-keys-select-method
+This variable controls the method used for key selection in
+@code{epa-select-keys}. The default value @code{buffer} pops up a
+special buffer where you can select the keys. If the value is
+@code{minibuffer}, @code{epa-select-keys} will instead prompt for the
+keys in the minibuffer, where you should type the keys separated by
+commas.
+@end defvar
+
@node Cryptographic operations on files
@section Cryptographic Operations on Files
@cindex cryptographic operations on files
diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi
index f877fb681fe..c7ab7e7bf21 100644
--- a/doc/misc/erc.texi
+++ b/doc/misc/erc.texi
@@ -1230,25 +1230,30 @@ machine Example.Net login aph-bot password sesame
(defun my-erc-up (network)
(interactive "Snetwork: ")
-
- (pcase network
- ('libera
- (let ((erc-sasl-mechanism 'external))
- (erc-tls :server "irc.libera.chat" :port 6697
- :client-certificate t)))
- ('example
- (let ((erc-sasl-auth-source-function
- #'erc-sasl-auth-source-password-as-host))
- (erc-tls :server "irc.example.net" :port 6697
- :user "alyssa"
- :password "Example.Net")))))
+ (require 'erc-sasl)
+ (or (let ((erc-modules (cons 'sasl erc-modules)))
+ (pcase network
+ ('libera
+ (let ((erc-sasl-mechanism 'external))
+ (erc-tls :server "irc.libera.chat"
+ :client-certificate t)))
+ ('example
+ (let ((erc-sasl-auth-source-function
+ #'erc-sasl-auth-source-password-as-host))
+ (erc-tls :server "irc.example.net"
+ :user "alyssa"
+ :password "Example.Net")))))
+ ;; Non-SASL
+ (call-interactively #'erc-tls)))
@end lisp
You've started storing your credentials with auth-source and have
decided to try SASL on another network as well. But there's a catch:
this network doesn't support @samp{EXTERNAL}. You use
-@code{let}-binding to get around this and successfully authenticate to
-both networks.
+@code{let}-binding to work around this and successfully authenticate
+to both networks. (Note that this example assumes you've removed
+@code{sasl} from @code{erc-modules} globally and have instead opted to
+add it locally when connecting to preconfigured networks.)
@end itemize
diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi
index da5e1ef1d03..30c85da795b 100644
--- a/doc/misc/eshell.texi
+++ b/doc/misc/eshell.texi
@@ -3,7 +3,7 @@
@setfilename ../../info/eshell.info
@settitle Eshell: The Emacs Shell
@include docstyle.texi
-@defindex cm
+@defcodeindex cm
@syncodeindex vr fn
@c %**end of header
@@ -416,7 +416,7 @@ elisp, The Emacs Lisp Reference Manual}).
@end table
@node Built-ins
-@section Built-in commands
+@section Built-in Commands
Eshell provides a number of built-in commands, many of them
implementing common command-line utilities, but enhanced for Eshell.
(These built-in commands are just ordinary Lisp functions whose names
@@ -477,98 +477,133 @@ default target for the commands @command{cp},
@command{mv}, and
@command{ln} is the current directory.
A few commands are wrappers for more niche Emacs features, and can be
-loaded as part of the eshell-xtra module. @xref{Extension modules}.
+loaded as part of the @code{eshell-xtra} module. @xref{Extra built-in
+commands}.
+
+@menu
+* List of Built-ins::
+* Defining New Built-ins::
+@end menu
+
+@node List of Built-ins
+@subsection List of Built-in Commands
@table @code
-@item .
@cmindex .
-Source an Eshell file in the current environment. This is not to be
-confused with the command @command{source}, which sources a file in a
-subshell environment.
+@item . @var{file} [@var{argument}]@dots{}
+Source an Eshell script named @var{file} in the current environment,
+passing any @var{arguments} to the script (@pxref{Scripts}). This is
+not to be confused with the command @command{source}, which sources a
+file in a subshell environment.
-@item addpath
@cmindex addpath
-Adds a given path or set of paths to the PATH environment variable, or,
-with no arguments, prints the current paths in this variable.
+@item addpath
+@itemx addpath [-b] @var{directory}@dots{}
+Adds each specified @var{directory} to the @code{$PATH} environment
+variable. By default, this adds the directories to the end of
+@code{$PATH}, in the order they were passed on the command line; by
+passing @code{-b} or @code{--begin}, Eshell will instead add the
+directories to the beginning.
+
+With no directories, print the list of directories currently stored in
+@code{$PATH}.
-@item alias
@cmindex alias
-Define an alias (@pxref{Aliases}). This adds it to the aliases file.
+@item alias
+@itemx alias @var{name} [@var{command}]
+Define an alias named @var{name} and expanding to @var{command},
+adding it to the aliases file (@pxref{Aliases}). If @var{command} is
+omitted, delete the alias named @var{name}. With no arguments at all,
+list all the currently-defined aliases.
-@item basename
@cmindex basename
-Return a file name without its directory.
+@item basename @var{filename}
+Return @var{filename} without its directory.
-@item cat
@cmindex cat
-Concatenate file contents into standard output. If in a pipeline, or
-if the file is not a regular file, directory, or symlink, then this
-command reverts to the system's definition of @command{cat}.
+@item cat @var{file}@dots{}
+Concatenate the contents of @var{file}s to standard output. If in a
+pipeline, or if any of the files is not a regular file, directory, or
+symlink, then this command reverts to the system's definition of
+@command{cat}.
-@item cd
@cmindex cd
-This command changes the current working directory. Usually, it is
-invoked as @kbd{cd @var{dir}} where @file{@var{dir}} is the new
-working directory. But @command{cd} knows about a few special
-arguments:
+@cindex directories, changing
+@item cd
+@itemx cd @var{directory}
+@itemx cd -[@var{n}]
+@itemx cd =[@var{regexp}]
+Change the current working directory. This command can take several
+forms:
-@itemize @minus{}
-@item
-When it receives no argument at all, it changes to the home directory.
+@table @code
-@item
-Giving the command @kbd{cd -} changes back to the previous working
-directory (this is the same as @kbd{cd $-}).
+@item cd
+Change to the user's home directory.
-@item
-The command @kbd{cd =} shows the directory ring. Each line is
-numbered.
+@item cd @var{directory}
+Change to the specified @var{directory}.
-@item
-With @kbd{cd =foo}, Eshell searches the directory ring for a directory
-matching the regular expression @samp{foo}, and changes to that
-directory.
+@item cd -
+Change back to the previous working directory (this is the same as
+@kbd{cd $-}).
-@item
-With @kbd{cd -42}, you can access the directory stack slots by number.
+@item cd -@var{n}
+Change to the directory in the @var{nth} slot of the directory stack.
+
+@item cd =
+Show the directory ring. Each line is numbered.
+
+@item cd =@var{regexp}
+Search the directory ring for a directory matching the regular
+expression @var{regexp} and change to that directory.
+
+@end table
-@item
@vindex eshell-cd-shows-directory
@vindex eshell-list-files-after-cd
If @code{eshell-cd-shows-directory} is non-@code{nil}, @command{cd}
will report the directory it changes to. If
@code{eshell-list-files-after-cd} is non-@code{nil}, then @command{ls}
is called with any remaining arguments after changing directories.
-@end itemize
-@item clear
@cmindex clear
+@item clear [@var{scrollback}]
Scrolls the contents of the Eshell window out of sight, leaving a
-blank window. If provided with an optional non-@code{nil} argument,
-the scrollback contents are cleared instead.
+blank window. If @var{scrollback} is non-@code{nil}, the scrollback
+contents are cleared instead, as with @command{clear-scrollback}.
-@item clear-scrollback
@cmindex clear-scrollback
+@item clear-scrollback
Clear the scrollback contents of the Eshell window. Unlike the
command @command{clear}, this command deletes content in the Eshell
buffer.
-@item compile
@cmindex compile
+@item compile [-p | -i] [-m @var{mode-name}] @var{command}@dots{}
Run an external command, sending its output to a compilation buffer if
the command would output to the screen and is not part of a pipeline
-or subcommand. This is particularly useful when defining aliases, so
+or subcommand.
+
+With the @code{-p} or @code{--plain} options, always send the output
+to the Eshell buffer; similarly, with @code{-i} or
+@code{--interactive}, always send the output to a compilation buffer.
+You can also set the mode of the compilation buffer with @code{-m
+@var{mode-name}} or @code{--mode @var{mode-name}}.
+
+@command{compile} is particularly useful when defining aliases, so
that interactively, the output shows up in a compilation buffer, but
you can still pipe the output elsewhere if desired. For example, if
you have a grep-like command on your system, you might define an alias
for it like so: @samp{alias mygrep 'compile --mode=grep-mode -- mygrep
$*'}.
-@item cp
@cmindex cp
-Copy a file to a new location or copy multiple files to the same
-directory.
+@item cp [@var{option}@dots{}] @var{source} @var{dest}
+@item cp [@var{option}@dots{}] @var{source}@dots{} @var{directory}
+Copy the file @var{source} to @var{dest} or @var{source} into
+@var{directory}.
@vindex eshell-cp-overwrite-files
@vindex eshell-cp-interactive-query
@@ -577,61 +612,145 @@ If @code{eshell-cp-overwrite-files} is non-@code{nil},
then
@code{eshell-cp-interactive-query} is non-@code{nil}, then
@command{cp} will ask before overwriting anything.
-@item date
+@command{cp} accepts the following options:
+
+@table @asis
+
+@item @code{-a}, @code{--archive}
+Equivalent to @code{--no-dereference --preserve --recursive}.
+
+@item @code{-d}, @code{--no-dereference}
+Don't dereference symbolic links when copying; instead, copy the link
+itself.
+
+@item @code{-f}, @code{--force}
+Never prompt for confirmation before copying a file.
+
+@item @code{-i}, @code{--interactive}
+Prompt for confirmation before copying a file if the target already
+exists.
+
+@item @code{-n}, @code{--preview}
+Run the command, but don't copy anything. This is useful if you
+want to preview what would be removed when calling @command{cp}.
+
+@item @code{-p}, @code{--preserve}
+Attempt to preserve file attributes when copying.
+
+@item @code{-r}, @code{-R}, @code{--recursive}
+Copy any specified directories and their contents recursively.
+
+@item @code{-v}, @code{--verbose}
+Print the name of each file before copying it.
+
+@end table
+
@cmindex date
+@item date [@var{specified-time} [@var{zone}]]
Print the current local time as a human-readable string. This command
-is similar to, but slightly different from, the GNU Coreutils
-@command{date} command.
+is an alias to the Emacs Lisp function @code{current-time-string}
+(@pxref{Time of Day,,, elisp, GNU Emacs Lisp Reference Manual}).
-@item diff
@cmindex diff
-Compare files using Emacs's internal @code{diff} (not to be confused
-with @code{ediff}). @xref{Comparing Files, , , emacs, The GNU Emacs
-Manual}.
+@item diff [@var{option}]@dots{} @var{old} @var{new}
+Compare the files @var{old} and @var{new} using Emacs's internal
+@code{diff} (not to be confused with @code{ediff}). @xref{Comparing
+Files, , , emacs, The GNU Emacs Manual}.
@vindex eshell-plain-diff-behavior
If @code{eshell-plain-diff-behavior} is non-@code{nil}, then this
command does not use Emacs's internal @code{diff}. This is the same
as using @samp{alias diff '*diff $@@*'}.
-@item dirname
@cmindex dirname
-Return the directory component of a file name.
+@item dirname @var{filename}
+Return the directory component of @var{filename}.
-@item dirs
@cmindex dirs
+@cindex directory stack, listing
+@item dirs
Prints the directory stack. Directories can be added or removed from
the stack using the commands @command{pushd} and @command{popd},
respectively.
-@item du
@cmindex du
-Summarize disk usage for each file.
+@item du [@var{option}]@dots{} @var{file}@dots{}
+Summarize disk usage for each file, recursing into directories.
+
+@command{du} accepts the following options:
+
+@table @asis
+
+@item @code{-a}, @code{--all}
+Print sizes for files, not just directories.
+
+@item @code{--block-size=@var{size}}
+Print sizes as number of blocks of size @var{size}.
+
+@item @code{-b}, @code{--bytes}
+Print file sizes in bytes.
+
+@item @code{-c}, @code{--total}
+Print a grand total of the sizes at the end.
+
+@item @code{-d}, @code{--max-depth=@var{depth}}
+Only print sizes for directories (or files with @code{--all}) that are
+@var{depth} or fewer levels below the command line arguments.
+
+@item @code{-h}, @code{--human-readable}
+Print sizes in human-readable format, with binary prefixes (so 1 KB is
+1024 bytes).
+
+@item @code{-H}, @code{--si}
+Print sizes in human-readable format, with decimal prefixes (so 1 KB
+is 1000 bytes).
+
+@item @code{-k}, @code{--kilobytes}
+Print file sizes in kilobytes (like @code{--block-size=1024}).
+
+@item @code{-L}, @code{--dereference}
+Follow symbolic links when traversing files.
+
+@item @code{-m}, @code{--megabytes}
+Print file sizes in megabytes (like @code{--block-size=1048576}).
+
+@item @code{-s}, @code{--summarize}
+Don't recurse into subdirectories (like @code{--max-depth=0}).
+
+@item @code{-x}, @code{--one-file-system}
+Skip any directories that reside on different filesystems.
+
+@end table
-@item echo
@cmindex echo
-Echoes its input. By default, this prints in a Lisp-friendly fashion
-(so that the value is useful to a Lisp command using the result of
-@command{echo} as an argument). If a single argument is passed,
-@command{echo} prints that; if multiple arguments are passed, it
-prints a list of all the arguments; otherwise, it prints the empty
-string.
+@item echo [-n | -N] [@var{arg}]@dots{}
+Prints the value of each @var{arg}. By default, this prints in a
+Lisp-friendly fashion (so that the value is useful to a Lisp command
+using the result of @command{echo} as an argument). If a single
+argument is passed, @command{echo} prints that; if multiple arguments
+are passed, it prints a list of all the arguments; otherwise, it
+prints the empty string.
@vindex eshell-plain-echo-behavior
If @code{eshell-plain-echo-behavior} is non-@code{nil}, @command{echo}
will try to behave more like a plain shell's @command{echo}, printing
each argument as a string, separated by a space.
-@item env
+You can control whether @command{echo} outputs a trailing newline
+using @code{-n} to disable the trailing newline (the default behavior)
+or @code{-N} to enable it (the default when
+@code{eshell-plain-echo-behavior} is non-@code{nil}).
+
@cmindex env
+@item env [@var{var}=@var{value}]@dots{} [@var{command}]@dots{}
With no arguments, print the current environment variables. If you
pass arguments to this command, then @command{env} will execute the
arguments as a command. If you pass any initial arguments of the form
@samp{@var{var}=@var{value}}, @command{env} will first set @var{var}
to @var{value} before running the command.
-@item eshell-debug
@cmindex eshell-debug
+@item eshell-debug [error | form | process]@dots{}
Toggle debugging information for Eshell itself. You can pass this
command one or more of the following arguments:
@@ -651,72 +770,95 @@ buffer @code{*eshell last cmd*}; or
@end itemize
-@item exit
@cmindex exit
+@item exit
@vindex eshell-kill-on-exit
Exit Eshell and save the history. By default, this command kills the
Eshell buffer, but if @code{eshell-kill-on-exit} is @code{nil}, then
the buffer is merely buried instead.
-@item export
@cmindex export
+@item export [@var{name}=@var{value}]@dots{}
Set environment variables using input like Bash's @command{export}, as
in @samp{export @var{var1}=@var{val1} @var{var2}=@var{val2} @dots{}}.
-@item grep
@cmindex grep
-@itemx agrep
+@item grep [@var{arg}]@dots{}
@cmindex agrep
-@itemx egrep
+@itemx agrep [@var{arg}]@dots{}
@cmindex egrep
-@itemx fgrep
+@itemx egrep [@var{arg}]@dots{}
@cmindex fgrep
-@itemx rgrep
+@itemx fgrep [@var{arg}]@dots{}
@cmindex rgrep
-@itemx glimpse
+@itemx rgrep [@var{arg}]@dots{}
@cmindex glimpse
+@itemx glimpse [@var{arg}]@dots{}
The @command{grep} commands are compatible with GNU @command{grep},
-but use Emacs's internal @code{grep} instead.
+but open a compilation buffer in @code{grep-mode} instead.
@xref{Grep Searching, , , emacs, The GNU Emacs Manual}.
@vindex eshell-plain-grep-behavior
If @code{eshell-plain-grep-behavior} is non-@code{nil}, then these
-commands do not use Emacs's internal @code{grep}. This is the same as
-using @samp{alias grep '*grep $@@*'}, though this setting applies to
-all of the built-in commands for which you would need to create a
-separate alias.
+commands do not use open a compilation buffer, instead printing output
+to Eshell's buffer. This is the same as using @samp{alias grep '*grep
+$@@*'}, though this setting applies to all of the built-in commands
+for which you would need to create a separate alias.
-@item history
@cmindex history
-Prints Eshell's input history. With a numeric argument @var{N}, this
-command prints the @var{N} most recent items in the history.
+@item history [@var{n}]
+@itemx history [-arw] [@var{filename}]
+Prints Eshell's input history. With a numeric argument @var{n}, this
+command prints the @var{n} most recent items in the history.
+Alternately, you can specify the following options:
+
+@table @asis
+
+@item @code{-a}, @code{--append}
+Append new history items to the history file.
+
+@item @code{-r}, @code{--read}
+Read history items from the history file and append them to the
+current shell's history.
+
+@item @code{-w}, @code{--write}
+Write the current history list to the history file.
+
+@end table
-@item info
@cmindex info
-Browse the available Info documentation. This command is the same as
-the external @command{info} command, but uses Emacs's internal Info
-reader.
-@xref{Misc Help, , , emacs, The GNU Emacs Manual}.
+@item info [@var{manual} [@var{item}]@dots{}]
+Browse the available Info documentation. With no arguments, browse
+the top-level menu. Otherwise, show the manual for @var{manual},
+selecting the menu entry for @var{item}.
+
+This command is the same as the external @command{info} command, but
+uses Emacs's internal Info reader. @xref{Misc Help, , , emacs, The
+GNU Emacs Manual}.
-@item jobs
@cmindex jobs
+@cindex processes, listing
+@item jobs
List subprocesses of the Emacs process, if any, using the function
@code{list-processes}.
-@item kill
@cmindex kill
+@cindex processes, signaling
+@item kill [-@var{signal}] [@var{pid} | @var{process}]
Kill processes. Takes a PID or a process object and an optional
-signal specifier which can either be a number or a signal name.
+@var{signal} specifier which can either be a number or a signal name.
-@item listify
@cmindex listify
-Eshell version of @code{list}. Allows you to create a list using Eshell
-syntax, rather than Elisp syntax. For example, @samp{listify foo bar}
-and @code{("foo" "bar")} both evaluate to @code{("foo" "bar")}.
+@item listify [@var{arg}]@dots{}
+Return the arguments as a single list. With a single argument, return
+it as-is if it's already a list, or otherwise wrap it in a list. With
+multiple arguments, return a list of all of them.
-@item ln
@cmindex ln
-Create links to files.
+@item ln [@var{option}]@dots{} @var{target} [@var{link-name}]
+@itemx ln [@var{option}]@dots{} @var{target}@dots{} @var{directory}
+Create a link to the specified @var{target} named @var{link-name} or
+create links to multiple @var{targets} in @var{directory}.
@vindex eshell-ln-overwrite-files
@vindex eshell-ln-interactive-query
@@ -725,8 +867,31 @@ will overwrite files without warning. If
@code{eshell-ln-interactive-query} is non-@code{nil}, then
@command{ln} will ask before overwriting files.
-@item locate
+@command{ln} accepts the following options:
+
+@table @asis
+
+@item @code{-f}, @code{--force}
+Never prompt for confirmation before linking a target.
+
+@item @code{-i}, @code{--interactive}
+Prompt for confirmation before linking to an item if the source
+already exists.
+
+@item @code{-n}, @code{--preview}
+Run the command, but don't move anything. This is useful if you
+want to preview what would be linked when calling @command{ln}.
+
+@item @code{-s}, @code{--symbolic}
+Make symbolic links instead of hard links.
+
+@item @code{-v}, @code{--verbose}
+Print the name of each file before linking it.
+
+@end table
+
@cmindex locate
+@item locate @var{arg}@dots{}
Alias to Emacs's @code{locate} function, which simply runs the external
@command{locate} command and parses the results.
@xref{Dired and Find, , , emacs, The GNU Emacs Manual}.
@@ -736,51 +901,129 @@ If @code{eshell-plain-locate-behavior} is
non-@code{nil}, then Emacs's
internal @code{locate} is not used. This is the same as using
@samp{alias locate '*locate $@@*'}.
-@item ls
@cmindex ls
-Lists the contents of directories.
+@item ls [@var{option}]@dots{} [@var{file}]@dots{}
+List information about each @var{file}, including the contents of any
+specified directories. If @var{file} is unspecified, list the
+contents of the current directory.
+
+@vindex eshell-ls-initial-args
+The user option @code{eshell-ls-initial-args} contains a list of
+arguments to include with any call to @command{ls}. For example, you
+can include the option @option{-h} to always use a more human-readable
+format.
@vindex eshell-ls-use-colors
If @code{eshell-ls-use-colors} is non-@code{nil}, the contents of a
directory is color-coded according to file type and status. These
colors and the regexps used to identify their corresponding files can
-be customized via @w{@kbd{M-x customize-group @key{RET} eshell-ls @key{RET}}}.
+be customized via @w{@kbd{M-x customize-group @key{RET} eshell-ls
+@key{RET}}}.
+
+@command{ls} supports the following options:
+
+@table @asis
+
+@item @code{-a}, @code{--all}
+List all files, including ones starting with @samp{.}.
+
+@item @code{-A}, @code{--almost-all}
+Like @code{--all}, but don't list the current directory (@file{.}) or
+the parent directory (@file{..}).
+
+@item @code{-c}, @code{--by-ctime}
+Sort files by last status change time, with newest files first.
+
+@item @code{-C}
+List entries by columns.
+
+@item @code{-d}, @code{--directory}
+List directory entries instead of their contents.
+
+@item @code{-h}, @code{--human-readable}
+Print sizes in human-readable format, with binary prefixes (so 1 KB is
+1024 bytes).
+
+@item @code{-H}, @code{--si}
+Print sizes in human-readable format, with decimal prefixes (so 1 KB
+is 1000 bytes).
+
+@item @code{-I@var{pattern}}, @code{--ignore=@var{pattern}}
+Don't list directory entries matching @var{pattern}.
+
+@item @code{-k}, @code{--kilobytes}
+Print sizes as 1024-byte kilobytes.
@vindex eshell-ls-date-format
-The user option @code{eshell-ls-date-format} determines how the date
-is displayed when using the @option{-l} option. The date is produced
-using the function @code{format-time-string} (@pxref{Time Parsing,,,
-elisp, GNU Emacs Lisp Reference Manual}).
+@item @code{-l}
+Use a long listing format showing details for each file. The user
+option @code{eshell-ls-date-format} determines how the date is
+displayed when using this option. The date is produced using the
+function @code{format-time-string} (@pxref{Time Parsing,,, elisp, GNU
+Emacs Lisp Reference Manual}).
-@vindex eshell-ls-initial-args
-The user option @code{eshell-ls-initial-args} contains a list of
-arguments to include with any call to @command{ls}. For example, you
-can include the option @option{-h} to always use a more human-readable
-format.
+@item @code{-L}, @code{--dereference}
+Follow symbolic links when listing entries.
+
+@item @code{-n}, @code{--numeric-uid-gid}
+Show UIDs and GIDs numerically, instead of using their names.
+
+@item @code{-r}, @code{--reverse}
+Reverse order when sorting.
+
+@item @code{-R}, @code{--recursive}
+List subdirectories recursively.
+
+@item @code{-s}, @code{--size}
+Show the size of each file in blocks.
@vindex eshell-ls-default-blocksize
-The user option @code{eshell-ls-default-blocksize} determines the
-default blocksize used when displaying file sizes with the option
-@option{-s}.
+@item @code{-S}
+Sort by file size, with largest files first. The user option
+@code{eshell-ls-default-blocksize} determines the default blocksize
+used when displaying file sizes with this option.
+
+@item @code{-t}
+Sort by modification time, with newest files first.
+
+@item @code{-u}
+Sort by last access time, with newest files first.
+
+@item @code{-U}
+Do not sort results. Instead, list entries in their directory order.
+
+@item @code{-x}
+List entries by lines instead of by columns.
+
+@item @code{-X}
+Sort alphabetically by file extension.
+
+@item @code{-1}
+List one file per line.
+
+@end table
-@item make
@cmindex make
+@item make [@var{arg}]@dots{}
Run @command{make} through @code{compile} when run asynchronously
(e.g., @samp{make &}). @xref{Compilation, , , emacs, The GNU Emacs
Manual}. Otherwise call the external @command{make} command.
-@item man
@cmindex man
+@item man [@var{arg}]@dots{}
Display Man pages using the Emacs @code{man} command.
@xref{Man Page, , , emacs, The GNU Emacs Manual}.
-@item mkdir
@cmindex mkdir
-Make new directories.
+@item mkdir [-p] @var{directory}@dots{}
+Make new directories. With @code{-p} or @code{--parents},
+automatically make any necessary parent directories as well.
-@item mv
@cmindex mv
-Move or rename files.
+@item mv [@var{option}]@dots{} @var{source} @var{dest}
+@itemx mv [@var{option}]@dots{} @var{source}@dots{} @var{directory}
+Rename the file @var{source} to @var{dest} or move @var{source} into
+@var{directory}.
@vindex eshell-mv-overwrite-files
@vindex eshell-mv-interactive-query
@@ -789,40 +1032,95 @@ will overwrite files without warning. If
@code{eshell-mv-interactive-query} is non-@code{nil}, @command{mv}
will prompt before overwriting anything.
-@item occur
+@command{mv} accepts the following options:
+
+@table @asis
+
+@item @code{-f}, @code{--force}
+Never prompt for confirmation before moving an item.
+
+@item @code{-i}, @code{--interactive}
+Prompt for confirmation before moving an item if the target already
+exists.
+
+@item @code{-n}, @code{--preview}
+Run the command, but don't move anything. This is useful if you
+want to preview what would be moved when calling @command{mv}.
+
+@item @code{-v}, @code{--verbose}
+Print the name of each item before moving it.
+
+@end table
+
@cmindex occur
+@item occur @var{regexp} [@var{nlines}]
Alias to Emacs's @code{occur}.
@xref{Other Repeating Search, , , emacs, The GNU Emacs Manual}.
-@item popd
@cmindex popd
+@cindex directory stack, removing from
+@item popd
+@item popd +@var{n}
Pop a directory from the directory stack and switch to a another place
-in the stack.
+in the stack. This command can take the following forms:
+
+@table @code
+
+@item popd
+Remove the current directory from the directory stack and change to
+the directory beneath it.
+
+@item popd +@var{n}
+Remove the current directory from the directory stack and change to
+the @var{nth} directory in the stack (counting from zero).
+
+@end table
-@item printnl
@cmindex printnl
-Print the arguments separated by newlines.
+@item printnl [@var{arg}]@dots{}
+Print all the @var{arg}s separated by newlines.
-@item pushd
@cmindex pushd
+@cindex directory stack, adding to
+@item pushd
+@itemx pushd @var{directory}
+@itemx pushd +@var{n}
Push the current directory onto the directory stack, then change to
-another directory.
+another directory. This command can take the following forms:
+
+@table @code
+
+@vindex eshell-pushd-tohome
+@item pushd
+Swap the current directory with the directory on the top of the stack.
+If @code{eshell-pushd-tohome} is non-@code{nil}, push the current
+directory onto the stack and change to the user's home directory (like
+@samp{pushd ~}).
@vindex eshell-pushd-dunique
+@item pushd @var{directory}
+Push the current directory onto the stack and change to
+@var{directory}. If @code{eshell-pushd-dunique} is non-@code{nil},
+then only unique directories will be added to the stack.
+
@vindex eshell-pushd-dextract
-If @code{eshell-pushd-dunique} is non-@code{nil}, then only unique
-directories will be added to the stack. If
-@code{eshell-pushd-dextract} is non-@code{nil}, then @samp{pushd
-+@var{n}} will pop the @var{n}th directory to the top of the stack.
+@item pushd +@var{n}
+Change to the @var{nth} directory in the directory stack (counting
+from zero), and ``rotate'' the stack by moving any elements before the
+@var{nth} to the bottom. If @code{eshell-pushd-dextract} is
+non-@code{nil}, then @samp{pushd +@var{n}} will instead pop the
+@var{n}th directory to the top of the stack.
+
+@end table
-@item pwd
@cmindex pwd
+@item pwd
Prints the current working directory.
-@item rm
@cmindex rm
+@item rm [@var{option}]@dots{} @var{item}@dots{}
Removes files, buffers, processes, or Emacs Lisp symbols, depending on
-the argument.
+the type of each @var{item}.
@vindex eshell-rm-interactive-query
@vindex eshell-rm-removes-directories
@@ -832,59 +1130,89 @@ will prompt before removing anything. If
@command{rm} can also remove directories. Otherwise, @command{rmdir}
is required.
-@item rmdir
+@command{rm} accepts the following options:
+
+@table @asis
+
+@item @code{-f}, @code{--force}
+Never prompt for confirmation before removing an item.
+
+@item @code{-i}, @code{--interactive}
+Prompt for confirmation before removing each item.
+
+@item @code{-n}, @code{--preview}
+Run the command, but don't remove anything. This is useful if you
+want to preview what would be removed when calling @command{rm}.
+
+@item @code{-r}, @code{-R}, @code{--recursive}
+Remove any specified directories and their contents recursively.
+
+@item @code{-v}, @code{--verbose}
+Print the name of each item before removing it.
+
+@end table
+
@cmindex rmdir
+@item rmdir @var{directory}@dots{}
Removes directories if they are empty.
-@item set
@cmindex set
+@item set [@var{var} @var{value}]@dots{}
Set variable values, using the function @code{set} like a command
(@pxref{Setting Variables,,, elisp, GNU Emacs Lisp Reference Manual}).
-A variable name can be a symbol, in which case it refers to a Lisp
-variable, or a string, referring to an environment variable
+The value of @var{var} can be a symbol, in which case it refers to a
+Lisp variable, or a string, referring to an environment variable
(@pxref{Arguments}).
-@item setq
@cmindex setq
+@item setq [@var{symbol} @var{value}]@dots{}
Set variable values, using the function @code{setq} like a command
(@pxref{Setting Variables,,, elisp, GNU Emacs Lisp Reference Manual}).
-@item source
@cmindex source
-Source an Eshell file in a subshell environment. This is not to be
-confused with the command @command{.}, which sources a file in the
-current environment.
+@item source @var{file} [@var{argument}]@dots{}
+Source an Eshell script named @var{file} in a subshell environment,
+passing any @var{argument}s to the script (@pxref{Scripts}). This is
+not to be confused with the command @command{.}, which sources a file
+in the current environment.
-@item time
@cmindex time
-Show the time elapsed during a command's execution.
+@item time @var{command}@dots{}
+Show the time elapsed during the execution of @var{command}.
-@item umask
@cmindex umask
-Set or view the default file permissions for newly created files and
-directories.
+@item umask [-S]
+@itemx umask @var{mode}
+View the default file permissions for newly created files and
+directories. If you pass @code{-S} or @code{--symbolic}, view the
+mode symbolically. With @var{mode}, set the default permissions to
+this value.
-@item unset
@cmindex unset
-Unset one or more variables. As with @command{set}, a variable name
-can be a symbol, in which case it refers to a Lisp variable, or a
-string, referring to an environment variable.
+@item unset [@var{var}]@dots{}
+Unset one or more variables. As with @command{set}, the value of
+@var{var} can be a symbol, in which case it refers to a Lisp variable,
+or a string, referring to an environment variable.
-@item wait
@cmindex wait
-Wait until a process has successfully completed.
+@cindex processes, waiting for
+@item wait [@var{process}]@dots{}
+Wait until each specified @var{process} has exited.
-@item which
@cmindex which
-Identify a command and its location.
+@item which @var{command}@dots{}
+For each @var{command}, identify what kind of command it is and its
+location.
-@item whoami
@cmindex whoami
-Print the current user. This Eshell version of @command{whoami}
-supports Tramp.
+@item whoami
+Print the current user. This Eshell version of @command{whoami} is
+connection-aware, so for remote directories, it will print the user
+associated with that connection.
@end table
-@subsection Defining new built-in commands
+@node Defining New Built-ins
+@subsection Defining New Built-in Commands
While Eshell can run Lisp functions directly as commands, it may be
more convenient to provide a special built-in command for
Eshell. Built-in commands are just ordinary Lisp functions designed
@@ -1180,7 +1508,7 @@ create and switch to a directory called @samp{foo}.
@node Remote Access
@section Remote Access
-@cmindex remote access
+@cindex remote access
Since Eshell uses Emacs facilities for most of its functionality, you
can access remote hosts transparently. To connect to a remote host,
@@ -1353,6 +1681,11 @@ sequence of commands, as with almost any other shell
script. Scripts
are invoked from Eshell with @command{source}, or from anywhere in Emacs
with @code{eshell-source-file}.
+Like with aliases (@pxref{Aliases}), Eshell scripts can accept any
+number of arguments. Within the script, you can refer to these with
+the special variables @code{$0}, @code{$1}, @dots{}, @code{$9}, and
+@code{$*}.
+
@cmindex .
If you wish to load a script into your @emph{current} environment,
rather than in a subshell, use the @code{.} command.
@@ -1452,7 +1785,7 @@ As with @samp{$@{@var{command}@}}, evaluates the Eshell
command invocation
@command{@var{command}}, but writes the output to a temporary file and
returns the file name.
-@item $@var{expr}[@var{i...}]
+@item $@var{expr}[@var{i@dots{}}]
Expands to the @var{i}th element of the result of @var{expr}, an
expression in one of the above forms listed here. If multiple indices
are supplied, this will return a list containing the elements for each
@@ -1501,7 +1834,7 @@ Multiple sets of indices can also be specified. For
example, if
expand to @code{2}, i.e.@: the second element of the first list member
(all indices are zero-based).
-@item $@var{expr}[@var{regexp} @var{i...}]
+@item $@var{expr}[@var{regexp} @var{i@dots{}}]
As above (when @var{expr} expands to a string), but use @var{regexp}
to split the string. @var{regexp} can be any form other than a
number. For example, @samp{$@var{var}[: 0]} will return the first
@@ -2275,15 +2608,23 @@ external commands. To enable it, add
@code{eshell-tramp} to
@table @code
-@item su
@cmindex su
-@itemx sudo
+@item su [- | -l] [@var{user}]
+Uses TRAMP's @command{su} method (@pxref{Inline methods, , , tramp,
+The Tramp Manual}) to change the current user to @var{user} (or root
+if unspecified). With @code{-}, @code{-l}, or @code{--login}, provide
+a login environment.
+
@cmindex sudo
-@itemx doas
+@item sudo [-u @var{user}] [-s | @var{command}@dots{}]
@cmindex doas
-Uses TRAMP's @command{su}, @command{sudo}, or @command{doas} method
-(@pxref{Inline methods, , , tramp, The Tramp Manual}) to run a command
-via @command{su}, @command{sudo}, or @command{doas}.
+@itemx doas [-u @var{user}] [-s | @var{command}@dots{}]
+Uses TRAMP's @command{sudo} or @command{doas} method (@pxref{Inline
+methods, , , tramp, The Tramp Manual}) to run @var{command} as root
+via @command{sudo} or @command{doas}. When specifying @code{-u
+@var{user}} or @code{--user @var{user}}, run the command as @var{user}
+instead. With @code{-s} or @code{--shell}, start a shell instead of
+running @var{command}.
@end table
@@ -2296,59 +2637,59 @@ add @code{eshell-xtra} to @code{eshell-modules-list}.
@table @code
-@item count
@cmindex count
+@item count @var{item} @var{seq} [@var{option}]@dots{}
A wrapper around the function @code{cl-count} (@pxref{Searching
Sequences,,, cl, GNU Emacs Common Lisp Emulation}). This command can
be used for comparing lists of strings.
-@item expr
@cmindex expr
+@item expr @var{str} [@var{separator}] [@var{arg}]@dots{}
An implementation of @command{expr} using the Calc package.
@xref{Top,,, calc, The GNU Emacs Calculator}.
-@item ff
@cmindex ff
+@item ff @var{directory} @var{pattern}
Shorthand for the the function @code{find-name-dired} (@pxref{Dired
and Find, , , emacs, The Emacs Editor}).
-@item gf
@cmindex gf
+@item gf @var{directory} @var{regexp}
Shorthand for the the function @code{find-grep-dired} (@pxref{Dired
and Find, , , emacs, The Emacs Editor}).
-@item intersection
@cmindex intersection
+@item intersection @var{list1} @var{list2} [@var{option}]@dots{}
A wrapper around the function @code{cl-intersection} (@pxref{Lists as
Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command
can be used for comparing lists of strings.
-@item mismatch
@cmindex mismatch
+@item mismatch @var{seq1} @var{seq2} [@var{option}]@dots{}
A wrapper around the function @code{cl-mismatch} (@pxref{Searching
Sequences,,, cl, GNU Emacs Common Lisp Emulation}). This command can
be used for comparing lists of strings.
-@item set-difference
@cmindex set-difference
+@item set-difference @var{list1} @var{list2} [@var{option}]@dots{}
A wrapper around the function @code{cl-set-difference} (@pxref{Lists
as Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command can be
used for comparing lists of strings.
-@item set-exclusive-or
@cmindex set-exclusive-or
+@item set-exclusive-or @var{list1} @var{list2} [@var{option}]@dots{}
A wrapper around the function @code{cl-set-exclusive-or} (@pxref{Lists
as Sets,,, cl, GNU Emacs Common Lisp Emulation}). This command can be
used for comparing lists of strings.
-@item substitute
@cmindex substitute
+@item substitute @var{new} @var{old} @var{seq} [@var{option}]@dots{}
A wrapper around the function @code{cl-substitute} (@pxref{Sequence
Functions,,, cl, GNU Emacs Common Lisp Emulation}). This command can
be used for comparing lists of strings.
-@item union
@cmindex union
+@item union @var{list1} @var{list2} [@var{option}]@dots{}
A wrapper around the function @code{cl-union} (@pxref{Lists as Sets,,,
cl, GNU Emacs Common Lisp Emulation}). This command can be used for
comparing lists of strings.
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi
index 08554d0d9b9..419a5390374 100644
--- a/doc/misc/gnus.texi
+++ b/doc/misc/gnus.texi
@@ -5832,10 +5832,11 @@ message to the mailing list, and include the original
message
@kindex S v @r{(Summary)}
@findex gnus-summary-very-wide-reply
Mail a very wide reply to the author of the current article
-(@code{gnus-summary-very-wide-reply}). A @dfn{very wide reply} is a reply
-that goes out to all people listed in the @code{To}, @code{From} (or
-@code{Reply-To}) and @code{Cc} headers in all the process/prefixed
-articles. This command uses the process/prefix convention.
+(@code{gnus-summary-very-wide-reply}). A @dfn{very wide reply} is a
+reply that goes out to all people listed in the @code{To}, @code{From}
+(or @code{Reply-To}) and @code{Cc} headers in all the process/prefixed
+articles. This command uses the process/prefix convention. If given a
+prefix argument, the body of the current article will also be yanked.
@item S V
@kindex S V @r{(Summary)}
@@ -26694,9 +26695,12 @@ buffers. It is enabled with
@table @kbd
@item C-c C-m C-a
@findex gnus-dired-attach
+@vindex gnus-dired-attach-at-end
@cindex attachments, selection via dired
Send dired's marked files as an attachment (@code{gnus-dired-attach}).
-You will be prompted for a message buffer.
+The function prompts for a message buffer, and by default attaches files
+to the end of that buffer; customize @code{gnus-dired-attach-at-end} to
+place the attachments at point instead.
@item C-c C-m C-l
@findex gnus-dired-find-file-mailcap
diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex
index e8c382f5967..93d592193a0 100644
--- a/doc/misc/texinfo.tex
+++ b/doc/misc/texinfo.tex
@@ -3,9 +3,9 @@
% Load plain if necessary, i.e., if running under initex.
\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi
%
-\def\texinfoversion{2023-09-19.19}
+\def\texinfoversion{2024-02-10.22}
%
-% Copyright 1985, 1986, 1988, 1990-2023 Free Software Foundation, Inc.
+% Copyright 1985, 1986, 1988, 1990-2024 Free Software Foundation, Inc.
%
% This texinfo.tex file is free software: you can redistribute it and/or
% modify it under the terms of the GNU General Public License as
@@ -5238,14 +5238,14 @@ $$%
% the current value of \escapechar.
\def\escapeisbackslash{\escapechar=`\\}
-% Use \ in index files by default. texi2dvi didn't support @ as the escape
-% character (as it checked for "\entry" in the files, and not "@entry"). When
-% the new version of texi2dvi has had a chance to become more prevalent, then
-% the escape character can change back to @ again. This should be an easy
-% change to make now because both @ and \ are only used as escape characters in
-% index files, never standing for themselves.
+% Uncomment to use \ in index files by default. Old texi2dvi (before 2019)
+% didn't support @ as the escape character (as it checked for "\entry" in
+% the files, and not "@entry").
+% In the future we can remove this flag and simplify the code for
+% index files and backslashes, once the support is no longer likely to be
+% useful.
%
-\set txiindexescapeisbackslash
+% \set txiindexescapeisbackslash
% Write the entry in \indextext to the index file.
%
@@ -6137,8 +6137,7 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% normally unnmhead0 calls unnumberedzzz:
\outer\parseargdef\unnumbered{\unnmhead0{#1}}
\def\unnumberedzzz#1{%
- \global\secno=0 \global\subsecno=0 \global\subsubsecno=0
- \global\advance\unnumberedno by 1
+ \global\advance\unnumberedno by 1
%
% Since an unnumbered has no number, no prefix for figures.
\global\let\chaplevelprefix = \empty
@@ -6194,8 +6193,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% normally calls unnumberedseczzz:
\outer\parseargdef\unnumberedsec{\unnmhead1{#1}}
\def\unnumberedseczzz#1{%
- \global\subsecno=0 \global\subsubsecno=0 \global\advance\secno by 1
- \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno.\the\secno}%
+ \global\advance\unnumberedno by 1
+ \sectionheading{#1}{sec}{Ynothing}{\the\unnumberedno}%
}
% Subsections.
@@ -6218,9 +6217,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% normally calls unnumberedsubseczzz:
\outer\parseargdef\unnumberedsubsec{\unnmhead2{#1}}
\def\unnumberedsubseczzz#1{%
- \global\subsubsecno=0 \global\advance\subsecno by 1
- \sectionheading{#1}{subsec}{Ynothing}%
- {\the\unnumberedno.\the\secno.\the\subsecno}%
+ \global\advance\unnumberedno by 1
+ \sectionheading{#1}{subsec}{Ynothing}{\the\unnumberedno}%
}
% Subsubsections.
@@ -6244,9 +6242,8 @@ might help (with 'rm \jobname.?? \jobname.??s')%
% normally unnumberedsubsubseczzz:
\outer\parseargdef\unnumberedsubsubsec{\unnmhead3{#1}}
\def\unnumberedsubsubseczzz#1{%
- \global\advance\subsubsecno by 1
- \sectionheading{#1}{subsubsec}{Ynothing}%
- {\the\unnumberedno.\the\secno.\the\subsecno.\the\subsubsecno}%
+ \global\advance\unnumberedno by 1
+ \sectionheading{#1}{subsubsec}{Ynothing}{\the\unnumberedno}%
}
% These macros control what the section commands do, according
@@ -8205,8 +8202,6 @@ might help (with 'rm \jobname.?? \jobname.??s')%
\let\commondummyword\unmacrodo
\xdef\macrolist{\macrolist}%
\endgroup
- \else
- \errmessage{Macro #1 not defined}%
\fi
}
diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi
index 56945d3071c..09b875ad3fa 100644
--- a/doc/misc/tramp.texi
+++ b/doc/misc/tramp.texi
@@ -523,9 +523,11 @@ is used as the group to change to. The default host name
is the same.
@cindex @option{sudo} method
@cindex method @option{doas}
@cindex @option{doas} method
+@cindex method @option{androidsu}
+@cindex @option{androidsu} method
If the @option{su}, @option{sudo} or @option{doas} option should be
-performed on another host, it can be comnbined with a leading
+performed on another host, it can be combined with a leading
@option{ssh} or @option{plink} option. That means that @value{tramp}
connects first to the other host with non-administrative credentials,
and changes to administrative credentials on that host afterwards. In
@@ -533,6 +535,11 @@ a simple case, the syntax looks like
@file{@trampfn{ssh@value{postfixhop}user@@host|sudo,,/path/to/file}}.
@xref{Ad-hoc multi-hops}.
+The @option{su} method and other shell-based methods conflict with
+non-standard @command{su} implementations popular among Android users
+and the restricted command-line utilities distributed with that system.
+The @option{androidsu} method enables accessing files through
+@command{su} on such systems, but multi-hops are not supported.
@anchor{Quick Start Guide sudoedit method}
@section Using @command{sudoedit}
@@ -1059,6 +1066,20 @@ session.
These methods support the @samp{-P} argument.
+@item @option{dockercp}
+@item @option{podmancp}
+@cindex method @option{dockercp}
+@cindex @option{dockercp} method
+@cindex method @option{podmancp}
+@cindex @option{podmancp} method
+
+These methods are similar to @option{docker} or @option{podman}, but
+they use the command @command{docker cp} or @command{podman cp} for
+transferring large files.
+
+These copy commands do not support file globs, and they ignore a user
+name.
+
@item @option{fcp}
@cindex method @option{fcp}
@cindex @option{fcp} method
@@ -5238,9 +5259,14 @@ Does @value{tramp} support @acronym{SSH} security keys?
Yes. @command{OpenSSH} has added support for @acronym{FIDO} hardware
devices via special key types @option{*-sk}. @value{tramp} supports
the additional handshaking messages for them. This requires at least
-@command{OpenSSH} 8.2, and a @acronym{FIDO} @acronym{U2F} compatible
-security key, like yubikey, solokey, nitrokey, or titankey.
-
+@command{OpenSSH} 8.2, and a @acronym{FIDO} @acronym{U2F} or
+@acronym{FIDO2} compatible security key, like yubikey, solokey,
+nitrokey, or titankey.
+@c @uref{https://docs.fedoraproject.org/en-US/quick-docs/using-yubikeys/}
+
+@strong{Note} that there are reports on problems of handling FIDO2
+(residential) keys by @command{ssh-agent}. As workaround, you might
+disable @command{ssh-agent} for such keys.
@item
@value{tramp} does not connect to Samba or MS Windows hosts running
diff --git a/doc/translations/README b/doc/translations/README
new file mode 100644
index 00000000000..02edb829dcf
--- /dev/null
+++ b/doc/translations/README
@@ -0,0 +1,211 @@
+* Translating the Emacs manuals
+
+** Copyright assignment
+
+People who contribute translated documents should provide a copyright
+assignment to the Free Software Foundation. See the "Copyright
+Assignment" section in the Emacs manual.
+
+
+** Translated documents license
+
+The translated documents are distributed under the same license as the
+original documents: the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation.
+
+See https://www.gnu.org/licenses/fdl-1.3.html for more information.
+
+If you have any questions regarding the use of the FDL license in your
+translation work that do not appear in the FAQ, feel free to contact the
+GNU project.
+
+See https://www.gnu.org/contact/ for more information.
+
+** Location of the translated files
+
+*** Texinfo source files
+
+The source files of the translated manuals are located in the
+doc/translations directory, under the sub-directory corresponding to the
+translated language.
+
+ E.g., French manual sources are found under doc/translations/fr.
+
+The structure of each language's folder should match that of the English
+manuals (i.e. include misc, man, lispref, lispintro, emacs).
+
+*** Built files
+
+Translated deliverables in Info format are built at release time and are
+made available for local installation.
+
+
+** Source files format
+
+The manuals and their translations are written in the Texinfo format
+(with the exception of the org-mode manual, which is written in Org, and
+illustrations for the Introduction to Emacs Lisp Programming, which are
+EPS files).
+
+See https://www.gnu.org/software/Texinfo/ for more information.
+
+You must install the Texinfo package in order to verify the translated
+files, and refer to the Texinfo manual for information on the various
+Texinfo features.
+
+Emacs has a Texinfo mode that highlights the parts of the Texinfo code
+to be translated for easy reference.
+
+
+*** Texinfo specific issues
+
+Until the Emacs/Texinfo projects provide better solutions, here are a
+few rules to follow:
+
+- Under each @node, add an @anchor that has the same content as the
+ original English @node.
+
+- Translate the @node content but leave the @anchor in English.
+
+- Most Emacs manuals are set to include the docstyle.Texi file. This
+ file adds the "@documentencoding UTF-8" directive to the targeted
+ manual. There is no need to add this directive in a manual that
+ includes docstyle.texi.
+
+- Add a @documentlanguage directive that includes your language.
+
+ E.g., @documentlanguage zh
+
+This directive currently has little effect but will be useful in the
+future.
+
+- The @author directive can be used for the translator's name.
+
+ E.g., @author traduit en français par Achile Talon
+
+
+** Fixing the original document
+
+During the course of the translation, you might encounter passages in
+the original document that need to be updated or otherwise corrected, or
+even run into a bug in Emacs. If you cannot immediately correct the
+problem, please file a bug report promptly.
+
+See the 'Bugs' section in the Emacs manual.
+
+** Sending your contributions
+
+Send your contributions (files or revisions) for review to the Emacs
+development list at emacs-devel@gnu.org. Subscribing to the list is not
+obligatory.
+
+Always send contributions in the format of the original document. Most
+of the content in the Emacs manuals is in Texinfo format, so please do
+not send contributions in derivative formats (e.g. info, html, docbook,
+plain text, etc.)
+
+Before sending files for review, please ensure that they have been
+thoroughly checked for spelling/grammar/typography by at least using the
+tools provided by Emacs.
+
+Please also make sure that the Texinfo files build properly on your
+system.
+
+Send your contributions as patches (git diff -p --stat), and prefer the
+git format-patch form, since that format allows for easier review and
+easier installation of the changes by the persons with write access to
+the repository.
+
+The Emacs project has a lot of coding, documentation and commenting
+conventions. Sending such patches allows the project managers to make
+sure that the contributions comply with the various conventions.
+
+
+** Discussing translation issues
+
+Translation-related discussions are welcome on the emacs development
+list. Discussions specific to your language do not have to be in
+English.
+
+
+** Translation teams
+
+The number of words in the Emacs manuals is over 2,000,000 words and
+growing. While one individual could theoretically translate all the
+files, it is more practical to work in language teams.
+
+If you have a small group of translators willing to help, please make
+sure that the files are properly reviewed before sending them to the
+Emacs development list (see above).
+
+Please refer to the translation-related documents maintained by the GNU
+Project, and contact your language translation team to learn the
+practices they have developed over the years.
+
+See https://www.gnu.org/server/standards/README.translations.html for
+more information.
+
+
+** Translation processes
+
+Emacs does not yet provide tools that significantly help the translation
+process. A few useful functions would be:
+
+- automatic lookup of a list of glossary items when starting to work on
+ a translation "unit" (paragraph or otherwise); such glossary terms
+ should be easily insertable at point,
+
+- automatic lookup of past translations to check for similarity and
+ improve homogeneity over the whole document set; such past translation
+ matches should be easily insertable at point, etc.
+
+
+*** Using the PO format as an intermediate translation format
+
+Although the PO format has not been developed with documentation in
+mind, it is well-known among free software translation teams, and you
+can easily use the po4a utility to convert Texinfo to PO for work in
+translation tools that support the PO format.
+
+See https://po4a.org for more information.
+
+However, regardless of the intermediate file format that you might use,
+you should only send files in the original format (Texinfo, org-mode,
+eps) for review and installation.
+
+
+*** Free tools that you can use in your processes
+
+A number of free software tools are available outside the Emacs project,
+to help translators (both amateur and professional) in the translation
+process.
+
+If they have any features that you think Emacs should implement, you are
+welcome to provide patches to the Emacs project.
+
+Such tools include:
+
+- the GNOME Translation Editor, https://wiki.gnome.org/Apps/Gtranslator/
+- KDE's Lokalize, https://apps.kde.org/lokalize/
+- OmegaT, https://omegat.org
+- the Okapi Framework, https://www.okapiframework.org
+- pootle, https://pootle.translatehouse.org
+
+etc.
+
+
+* Licence of this document
+
+Copyright (C) 2024 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification, are
+permitted in any medium without royalty provided the copyright notice
+and this notice are preserved. This file is offered as-is, without any
+warranty.
+
+
+Local Variables:
+mode: outline
+paragraph-separate: "[ ]*$"
+coding: utf-8
+End:
diff --git a/doc/lang/fr/misc/ses-fr.texi b/doc/translations/fr/misc/ses-fr.texi
similarity index 100%
rename from doc/lang/fr/misc/ses-fr.texi
rename to doc/translations/fr/misc/ses-fr.texi
diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS
index f91d3fcb351..d7f513addfb 100644
--- a/etc/ERC-NEWS
+++ b/etc/ERC-NEWS
@@ -334,6 +334,11 @@ has changed in some way. At present, ERC does not perform
this step
automatically on your behalf, even if a change was made in a
'Custom-mode' buffer or via 'setopt'.
+** New broadcast-oriented slash commands /AME, /GME, and /GMSG.
+Also available as the library functions 'erc-cmd-AME', 'erc-cmd-GME',
+and 'erc-cmd-GMSG', these new slash commands can prove handy in test
+environments.
+
** Miscellaneous UX changes.
Some minor quality-of-life niceties have finally made their way to
ERC. For example, fool visibility has become togglable with the new
@@ -435,9 +440,12 @@ contains unique closures and thus no longer proves
effective for
traversing inserted messages. For now, ERC only provides an internal
means of visiting messages, but a public interface is forthcoming.
Also affecting the 'stamp' module is the deprecation of the function
-'erc-insert-aligned' and its removal from client code. Additionally,
-the module now merges its 'invisible' property with existing ones and
-includes all white space around stamps when doing so.
+'erc-insert-aligned' and its removal from the default client's code.
+In the same library, the function 'erc-munge-invisibility-spec' has
+been renamed to 'erc-stamp--manage-local-options-state' to better
+reflect its purpose. Additionally, the module now merges its
+'invisible' property with existing ones and includes all white space
+around stamps when doing so.
This "propertizing" of surrounding white space extends to all
'stamp'-applied properties, like 'field', in all intervening space
@@ -499,6 +507,16 @@ encouraged to keep a module's name aligned with its
group's as well as
the provided feature of its containing library, if only for the usual
reasons of namespace hygiene and discoverability.
+*** The function 'erc-open' no longer uses the 'TGT-LIST' parameter.
+ERC has always used the parameter to initialize the local variable
+'erc-default-recipients', which stores a list of routing targets with
+the topmost considered "active." However, since at least ERC 5.1, a
+buffer and its active target effectively mate for life, making
+'TGT-LIST', in practice, a read-only list of a single target. And
+because that target must also appear as the 'CHANNEL' parameter,
+'TGT-LIST' mainly serves to reinforce 'erc-open's reputation of being
+unruly.
+
*** ERC supports arbitrary CHANTYPES.
Specifically, channels can be prefixed with any predesignated
character, mainly to afford more flexibility to specialty services,
@@ -681,8 +699,6 @@ by toggling a provided compatibility switch. See source
code around
the function 'erc-send-action' for details.
*** Miscellaneous changes
-Two helper macros from GNU ELPA's Compat library are now available to
-third-party modules as 'erc-compat-call' and 'erc-compat-function'.
In 'erc-button-alist', 'Info-goto-node' has been supplanted by plain
old 'info', and the "<URL:...>" entry has been removed because it was
more or less redundant. In all ERC buffers, the "<TAB>" key is now
@@ -1364,7 +1380,7 @@ reconnection attempts that ERC will make per server.
in seconds, that ERC will wait between successive reconnect attempts.
*** erc-server-send-ping-timeout: Determines when to consider a connection
-stalled and restart it. The default is after 120 seconds.
+stalled and restart it. The default is after 120 seconds.
*** erc-system-name: Determines the system name to use when logging in.
The default is to figure this out by calling `system-name'.
@@ -2325,7 +2341,7 @@ in XEmacs.
Please use M-x customize-variable RET erc-modules RET to change the
default if it does not suite your needs.
-** THe symbol used in `erc-nickserv-passwords' for debian.org IRC servers
+** The symbol used in `erc-nickserv-passwords' for debian.org IRC servers
(formerly called OpenProjects, now FreeNode) has changed from
openprojects to freenode. You may need to update your configuration
for a successful automatic nickserv identification.
diff --git a/etc/NEWS b/etc/NEWS
index a21f45481fd..b4a1c887f2e 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -76,7 +76,7 @@ see the variable 'url-request-extra-headers'.
+++
** 'completion-auto-help' now affects 'icomplete-in-buffer'.
-Previously, completion-auto-help mostly affected only minibuffer
+Previously, 'completion-auto-help' mostly affected only minibuffer
completion. Now, if 'completion-auto-help' has the value 'lazy', then
Icomplete's in-buffer display of possible completions will only appear
after the 'completion-at-point' command has been invoked twice, and if
@@ -85,12 +85,12 @@ completely suppressed. Thus, if you use
'icomplete-in-buffer', ensure
'completion-auto-help' is not customized to 'lazy' or nil.
+++
-** The *Completions* buffer now always accompanies 'icomplete-in-buffer'.
-Previously, it was not consistent when the *Completions* buffer would
-appear when using 'icomplete-in-buffer'. Now the *Completions* buffer
+** The "*Completions*" buffer now always accompanies 'icomplete-in-buffer'.
+Previously, it was not consistent whether the "*Completions*" buffer would
+appear when using 'icomplete-in-buffer'. Now the "*Completions*" buffer
and Icomplete's in-buffer display of possible completions always
appear together. If you would prefer to see only Icomplete's
-in-buffer display, and not the *Completions* buffer, you can add this
+in-buffer display, and not the "*Completions*" buffer, you can add this
to your init:
(advice-add 'completion-at-point :after #'minibuffer-hide-completions)
@@ -130,6 +130,17 @@ the signature) the automatically inferred function type as
well.
This user option controls outline visibility in the output buffer of
'describe-bindings' when 'describe-bindings-outline' is non-nil.
+---
+*** 'C-h m' ('describe-mode') uses outlining by default.
+Set 'describe-mode-outline' to nil to get back the old behavior.
+
+** Outline Mode
+
++++
+*** 'outline-minor-mode' is supported in tree-sitter major modes.
+It can be used in all tree-sitter major modes that set either the
+variable 'treesit-simple-imenu-settings' or 'treesit-outline-predicate'.
+
** X selection requests are now handled much faster and asynchronously.
This means it should be less necessary to disable the likes of
'select-active-regions' when Emacs is running over a slow network
@@ -258,7 +269,7 @@ right-aligned to is controlled by the new user option
** Windows
-*** New action alist entry 'post-command-select-window' for display-buffer.
+*** New action alist entry 'post-command-select-window' for 'display-buffer'.
It specifies whether the window of the displayed buffer should be
selected or deselected at the end of executing the current command.
@@ -305,8 +316,17 @@ between the auto save file and the current file.
---
** 'ffap-lax-url' now defaults to nil.
-Previously, it was set to 'ffap-lax-url' to t but this broke remote file
-name detection.
+Previously, it was set to t but this broke remote file name detection.
+
++++
+** Multi-character key echo now ends with a suggestion to use Help.
+Customize 'echo-keystrokes-help' to nil to prevent that.
+
++++
+** 'read-passwd' can toggle the visibility of passwords.
+Use 'TAB' in the minibuffer to show or hide the password. Likewise,
+there is an icon on the mode-line, which toggles the visibility of the
+password when clicking with 'mouse-1'.
* Editing Changes in Emacs 30.1
@@ -318,7 +338,9 @@ will receive a 'wrap-prefix' automatically computed from
the line's
surrounding context, such that continuation lines are indented on
display as if they were filled with 'M-q' or similar. Unlike 'M-q',
the indentation only happens on display, and doesn't change the buffer
-text in any way.
+text in any way. The global minor mode
+'global-visual-wrap-prefix-mode' enables this minor mode in all
+buffers.
(This minor mode is the 'adaptive-wrap' ELPA package renamed and
lightly edited for inclusion in Emacs.)
@@ -418,6 +440,11 @@ respectively, in addition to the existing translations
'C-x 8 / e' and
* Changes in Specialized Modes and Packages in Emacs 30.1
+---
+** Titdic-cnv
+Most of the variables and functions in the file have been renamed to
+make sure they all use a 'tit-' namespace prefix.
+
---
** Trace
In batch mode, tracing now sends the trace to stdout.
@@ -431,7 +458,7 @@ configurations such as X11 when the X server does not
support at least
version 2.1 of the X Input Extension, and 'xterm-mouse-mode'.
** 'xterm-mouse-mode'
-This mode now emits `wheel-up/down/right/left' events instead of
+This mode now emits 'wheel-up/down/right/left' events instead of
'mouse-4/5/6/7' events for the mouse wheel.
It uses the 'mouse-wheel-up/down/left/right-event'
variables to decide which button maps to which wheel event (if any).
@@ -440,11 +467,14 @@ variables to decide which button maps to which wheel
event (if any).
---
*** New user option 'Info-url-alist'.
-This user option associates manual-names with URLs. It affects the
+This user option associates manual names with URLs. It affects the
'Info-goto-node-web' command. By default, associations for all
Emacs-included manuals are set. Further associations can be added for
arbitrary Info manuals.
+*** Emacs can now display Info manuals compressed with 'lzip'.
+This requires the 'lzip' program to be installed on your system.
+
+++
** New command 'lldb'.
Run the LLDB debugger, analogous to the 'gud-gdb' command.
@@ -572,6 +602,14 @@ It allows tweaking the thresholds for rename and copy
detection.
** Diff mode
+---
+*** New user option 'diff-refine-nonmodified'.
+When this is non-nil, 'diff-refine' will highlight lines that were added
+or removed in their entirety (as opposed to modified lines, where some
+parts of the line were modified), using the same faces as for
+highlighting the words added and removed within modified lines. The
+default value is nil.
+
+++
*** 'diff-ignore-whitespace-hunk' can now be applied to all hunks.
When called with a non-nil prefix argument,
@@ -689,7 +727,7 @@ arguments of the form 'VAR=VALUE', 'env' will first set
'VAR' to
Now, you can pass an argument like "u+w,o-r" to Eshell's 'umask'
command, which will give write permission for owners of newly-created
files and deny read permission for users who are not members of the
-file's group. See the Info node '(coreutils)File permissions' for
+file's group. See the Info node "(coreutils) File permissions" for
more information on this notation.
+++
@@ -808,14 +846,14 @@ in the minibuffer history, with more recent candidates
appearing first.
*** 'completion-category-overrides' supports more metadata.
The new supported completion properties are 'cycle-sort-function',
'display-sort-function', 'annotation-function', 'affixation-function',
-'group-function'. You can now customize them for any category in
+and 'group-function'. You can now customize them for any category in
'completion-category-overrides' that will override the properties
defined in completion metadata.
+++
*** 'completion-extra-properties' supports more metadata.
The new supported completion properties are 'category',
-'group-function', 'display-sort-function', 'cycle-sort-function'.
+'group-function', 'display-sort-function', and 'cycle-sort-function'.
** Pcomplete
@@ -864,6 +902,16 @@ mode line. 'header' will display in the header line;
** Tramp
++++
+*** New connection method "androidsu".
+This provides access to system files with elevated privileges granted by
+the idiosyncratic 'su' implementations and system utilities customary on
+Android.
+
++++
+*** New connection methods "dockercp" and "podmancp".
+These are the external methods counterparts of "docker" and "podman".
+
+++
*** New connection methods "toolbox" and "flatpak".
They allow accessing system containers provided by Toolbox or
@@ -1057,8 +1105,8 @@ 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.
-** Json mode
-`js-json-mode` does not derive from `js-mode` any more so as not
+** Json mode.
+'js-json-mode' does not derive from 'js-mode' any more so as not
to confuse tools like Eglot or YASnippet into thinking that those
buffers contain Javascript code.
@@ -1097,6 +1145,12 @@ 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 'gmane'.
+---
+*** New user option 'gnus-mode-line-logo'.
+This allows the user to either disable the display of any logo or
+specify which logo will be displayed as part of the
+buffer-identification in the mode-line of Gnus buffers.
+
** Rmail
---
@@ -1168,6 +1222,11 @@ Previously, the '@' character, which normally has
'symbol' syntax,
would combine with a following Lisp symbol and interfere with symbol
searching.
+---
+*** 'emacs-lisp-docstring-fill-column' now defaults to 72.
+It was previously 65. The new default formats documentation strings to
+fit on fewer lines without negatively impacting readability.
+
** CPerl mode
---
@@ -1188,8 +1247,8 @@ comment, like Perl mode does.
*** New command 'cperl-file-style'.
This command sets the indentation style for the current buffer. To
-change the default style, either use the option with the same name or
-use the command cperl-set-style.
+change the default style, either use the user option with the same name
+or use the command 'cperl-set-style'.
*** Commands using the Perl info page are obsolete.
The Perl documentation in info format is no longer distributed with
@@ -1297,21 +1356,51 @@ will return the URL for that bug.
This allows for rcirc logs to use a custom timestamp format, than the
chat buffers use by default.
+---
+*** New command 'Buffer-menu-toggle-internal'.
+This command toggles the display of internal buffers in Buffer Menu mode;
+that is, buffers not visiting a file and whose names start with a space.
+Previously, such buffers were never shown. This command is bound to 'I'
+in Buffer Menu mode.
+
** Customize
+++
*** New command 'customize-dirlocals'.
This command pops up a buffer to edit the settings in ".dir-locals.el".
+
+---
+** New command 'customize-toggle-option'.
+This command can toggle boolean options for the duration of a session.
+
** Calc
+
+++
-*** Calc parses fractions written using U+2044 FRACTION SLASH
-Fractions of the form 123⁄456 are handled as if written 123:456. Note
-in particular the difference in behavior from U+2215 DIVISION SLASH
+*** Calc parses fractions written using U+2044 FRACTION SLASH.
+Fractions of the form "123⁄456" are handled as if written "123:456".
+Note in particular the difference in behavior from U+2215 DIVISION SLASH
and U+002F SOLIDUS, which result in division rather than a rational
-fraction. You may also be interested to know that precomposed
-fraction characters, such as ½ (U+00BD VULGAR FRACTION ONE HALF), are
-also recognized as rational fractions. They have been since 2004, but
-it looks like it was never mentioned in the NEWS, or even the manual.
+fraction. You may also be interested to know that precomposed fraction
+characters, such as ½ (U+00BD VULGAR FRACTION ONE HALF), are also
+recognized as rational fractions. They have been since 2004, but it
+looks like it was never mentioned in the NEWS, or even the manual.
+
+** IELM
+
+---
+*** IELM now remembers input history between sessions.
+The new user option 'ielm-history-file-name' is the name of the file
+where IELM input history will be saved. Customize it to nil to revert
+to the old behavior of not remembering input history between sessions.
+
+** EasyPG
+
++++
+*** New user option 'epa-keys-select-method'.
+This allows the user to customize the key selection method, which can be
+either by using a pop-up buffer or from the minibuffer. The pop-up
+buffer method is the default, which preserves previous behavior.
+
* New Modes and Packages in Emacs 30.1
@@ -1367,13 +1456,30 @@ This minor mode generates the tags table automatically
based on the
current project configuration, and later updates it as you edit the
files and save the changes.
++++
+** New package Compat.
+Emacs now comes with a stub implementation of the
+forwards-compatibility Compat package from GNU ELPA. This allows
+built-in packages to use the library more effectively, and helps
+preventing the installation of Compat if unnecessary.
+
* Incompatible Lisp Changes in Emacs 30.1
+---
+** Old derived.el functions removed.
+The following functions have been deleted because they were only used
+by code compiled with Emacs<21:
+'derived-mode-init-mode-variables', 'derived-mode-merge-abbrev-tables',
+'derived-mode-merge-keymaps', 'derived-mode-merge-syntax-tables',
+'derived-mode-run-hooks', 'derived-mode-set-abbrev-table',
+'derived-mode-set-keymap', 'derived-mode-set-syntax-table',
+'derived-mode-setup-function-name'.
+
+++
** 'M-TAB' now invokes 'completion-at-point' also in Text mode.
By default, Text mode no longer binds 'M-TAB' to
-'ispell-complete-word'. Instead this mode arranges for
+'ispell-complete-word'. Instead, this mode arranges for
'completion-at-point', globally bound to 'M-TAB', to perform word
completion as well. You can have Text mode bind 'M-TAB' to
'ispell-complete-word' as it did in previous Emacs versions, or
@@ -1481,8 +1587,12 @@ values.
* Lisp Changes in Emacs 30.1
+++
-** 'define-advice' now sets the new advice's 'name' property to NAME
-Named advice defined with 'define-advice' can now be removed with
+** Pcase's functions (in 'pred' and 'app') can specify the argument position.
+For example, instead of '(pred (< 5))' you can write '(pred (> _ 5))'.
+
++++
+** 'define-advice' now sets the new advice's 'name' property to NAME.
+Named advices defined with 'define-advice' can now be removed with
'(advice-remove SYMBOL NAME)' in addition to '(advice-remove SYMBOL
SYMBOL@NAME)'.
@@ -1499,10 +1609,10 @@ It puts a limit to the amount by which Emacs can
temporarily increase
+++
** New special form 'handler-bind'.
-Provides a functionality similar to `condition-case` except it runs the
-handler code without unwinding the stack, such that we can record the
-backtrace and other dynamic state at the point of the error.
-See the Info node "(elisp) Handling Errors".
+It provides a functionality similar to 'condition-case' except it runs
+the handler code without unwinding the stack, such that we can record
+the backtrace and other dynamic state at the point of the error. See
+the Info node "(elisp) Handling Errors".
+++
** New 'pop-up-frames' action alist entry for 'display-buffer'.
@@ -1513,6 +1623,11 @@ precedence over the variable when present.
Mostly used internally to do a kind of topological sort of
inheritance hierarchies.
+** New function 'sort-on'.
+This function implements the Schwartzian transform, and is appropriate
+for sorting lists when the computation of the sort key of a list
+element can be expensive.
+
** New API for 'derived-mode-p' and control of the graph of major modes.
*** 'derived-mode-p' now takes the list of modes as a single argument.
@@ -1826,6 +1941,21 @@ name 'ignored-return-value'.
The warning will only be issued for calls to functions declared
'important-return-value' or 'side-effect-free' (but not 'error-free').
+---
+*** Warn about docstrings that contain control characters.
+The compiler now warns about docstrings with control characters other
+than newline and tab. This is often a result of improper escaping.
+Example:
+
+ (defun my-fun ()
+ "Uses c:\remote\dir\files and the key \C-x."
+ ...)
+
+where the docstring contains four control characters 'CR', 'DEL', 'FF'
+and 'C-x'.
+
+The warning name is 'docstrings-control-chars'.
+
---
*** The warning about wide docstrings can now be disabled separately.
Its warning name is 'docstrings-wide'.
@@ -1836,6 +1966,13 @@ The declaration '(important-return-value t)' sets the
'important-return-value' property which indicates that the function
return value should probably not be thrown away implicitly.
+** Bytecode is now always loaded eagerly.
+Bytecode compiled with older Emacs versions for lazy loading using
+'byte-compile-dynamic' is now loaded all at once.
+As a consequence, 'fetch-bytecode' has no use, does nothing, and is
+now obsolete. The variable 'byte-compile-dynamic' has no effect any
+more; compilation will always yield bytecode for eager loading.
+
+++
** New functions 'file-user-uid' and 'file-group-gid'.
These functions are like 'user-uid' and 'group-gid', respectively, but
@@ -1891,6 +2028,31 @@ The 'test' parameter is omitted if it is 'eql' (the
default), as is
'data' if empty. 'rehash-size', 'rehash-threshold' and 'size' are
always omitted, and ignored if present when the object is read back in.
+** Obarrays
+
++++
+*** New obarray type.
+Obarrays are now represented by an opaque type instead of using vectors.
+They are created by 'obarray-make' and manage their internal storage
+automatically, which means that the size parameter to 'obarray-make' can
+safely be omitted. That is, they do not become slower as they fill up.
+
+The old vector representation is still accepted by functions operating
+on obarrays, but 'obarrayp' only returns t for obarray objects.
+'type-of' now returns 'obarray' for obarray objects.
+
+Old code which (incorrectly) created "obarrays" as Lisp vectors filled
+with something other than 0, as in '(make-vector N nil)', will no longer
+work, and should be rewritten to use 'obarray-make'. Alternatively, you
+can fill the vector with 0.
+
++++
+*** New function 'obarray-clear' removes all symbols from an obarray.
+
+---
+*** 'obarray-size' and 'obarray-default-size' are now obsolete.
+They pertained to the internal storage size which is now irrelevant.
+
+++
** 'treesit-install-language-grammar' can handle local directory instead of
URL.
It is now possible to pass a directory of a local repository as URL
diff --git a/etc/NEWS.25 b/etc/NEWS.25
index 3c5e9569b49..f647809074b 100644
--- a/etc/NEWS.25
+++ b/etc/NEWS.25
@@ -1158,6 +1158,11 @@ few or no entries have changed.
* New Modes and Packages in Emacs 25.1
+** New preloaded package 'obarray'
+
+Provides obarray operations under the 'obarray-' prefix, such as
+'obarray-make', 'obarrayp', and 'obarray-map'.
+
** pinentry.el allows GnuPG passphrase to be prompted through the
minibuffer instead of a graphical dialog, depending on whether the gpg
command is called from Emacs (i.e., INSIDE_EMACS environment variable
diff --git a/etc/PROBLEMS b/etc/PROBLEMS
index 048c56baa1a..19456640299 100644
--- a/etc/PROBLEMS
+++ b/etc/PROBLEMS
@@ -432,7 +432,7 @@ than the corresponding .el file.
Alternatively, if you set the option 'load-prefer-newer' non-nil,
Emacs will load whichever version of a file is the newest.
-*** Watch out for the EMACSLOADPATH environment variable
+*** Watch out for the EMACSLOADPATH environment variable.
EMACSLOADPATH overrides which directories the function "load" will search.
@@ -441,7 +441,7 @@ environment.
** Keyboard problems
-*** PGTK build of Emacs running on Wayland doesn't recognize Hyper modifier
+*** PGTK build of Emacs running on Wayland doesn't recognize Hyper modifier.
If you arrange for the Wayland compositor to send the Hyper key
modifier (e.g., via XKB customizations), the Hyper modifier will still
@@ -452,6 +452,17 @@ Since GDK 3.x is no longer developed, this bug in GDK will
probably
never be solved. And the Emacs PGTK build cannot yet support GTK4,
where this problem is reportedly solved.
+*** Emacs built with GTK lags in its response to keyboard input.
+This can happen when input methods are used. It happens because Emacs
+behaves in an unconventional way with respect to GTK input methods: it
+registers to receive keyboard input as unprocessed key events with
+metadata (as opposed to receiving them as text strings). Most GTK
+programs use the latter approach, so some modern input methods have
+bugs and misbehave when faced with the way Emacs does it.
+
+A workaround is to set GTK_IM_MODULE=none in the environment, or maybe
+find a different input method without these problems.
+
*** Unable to enter the M-| key on some German keyboards.
Some users have reported that M-| suffers from "keyboard ghosting".
This can't be fixed by Emacs, as the keypress never gets passed to it
@@ -476,6 +487,29 @@ You are probably using a shell that doesn't support job
control, even
though the system itself is capable of it. Either use a different shell,
or set the variable 'cannot-suspend' to a non-nil value.
+*** Emacs running on WSL receives stray characters as input.
+
+For example, you could see Emacs inserting 'z' characters even though
+nothing is typed on the keyboard, and even if you unplug the keyboard.
+
+The reason is a bug in the WSL X server's handling of key-press and
+key-repeat events. A workaround is to use the Cygwin or native
+MS-Windows build of Emacs instead.
+
+*** On MS-Windows, the Windows key gets "stuck".
+When this problem happens, Windows behaves as if the Windows key were
+permanently pressed down. This could be a side effect of Emacs on
+MS-Windows hooking keyboard input on a low level, in order to support
+registering the Windows keys as hot keys. If that hook takes too much
+time for some reason, Windows can decide to remove the hook, which
+then has this effect.
+
+This is arguably a bug in Emacs, for which we don't yet have a
+solution. To work around, set the 'LowLevelHooksTimeout' value in the
+registry key "HKEY_CURRENT_USER\Control Panel\Desktop" to a number
+higher than 200 msec; the maximum allowed value is 1000 msec (create
+the value if it doesn't exist under that key).
+
** Mailers and other helper programs
*** movemail compiled with POP support can't connect to the POP server.
@@ -545,15 +579,6 @@ As a workaround, input the passphrase with a GUI-capable
pinentry
program like 'pinentry-gnome' or 'pinentry-qt5'. Alternatively, you
can use the 'pinentry' package from Emacs 25.
-*** Emacs running on WSL receives stray characters as input.
-
-For example, you could see Emacs inserting 'z' characters even though
-nothing is typed on the keyboard, and even if you unplug the keyboard.
-
-The reason is a bug in the WSL X server's handling of key-press and
-key-repeat events. A workaround is to use the Cygwin or native
-MS-Windows build of Emacs instead.
-
** Problems with hostname resolution
*** Emacs does not know your host's fully-qualified domain name.
diff --git a/etc/emacs_lldb.py b/etc/emacs_lldb.py
index fdf4314e2d0..9865fe391a2 100644
--- a/etc/emacs_lldb.py
+++ b/etc/emacs_lldb.py
@@ -56,6 +56,7 @@ class Lisp_Object:
"PVEC_BOOL_VECTOR": "struct Lisp_Bool_Vector",
"PVEC_BUFFER": "struct buffer",
"PVEC_HASH_TABLE": "struct Lisp_Hash_Table",
+ "PVEC_OBARRAY": "struct Lisp_Obarray",
"PVEC_TERMINAL": "struct terminal",
"PVEC_WINDOW_CONFIGURATION": "struct save_window_data",
"PVEC_SUBR": "struct Lisp_Subr",
diff --git a/etc/images/README b/etc/images/README
index a778d9ce6c3..8e112448373 100644
--- a/etc/images/README
+++ b/etc/images/README
@@ -125,7 +125,7 @@ For more information see the adwaita-icon-theme repository
at:
https://gitlab.gnome.org/GNOME/adwaita-icon-theme
-Emacs images and their source in the Adwaita/scalable directory:
+Emacs images and their source in the Adwaita/symbolic directory:
checked.svg ui/checkbox-checked-symbolic.svg
unchecked.svg ui/checkbox-symbolic.svg
@@ -137,3 +137,8 @@ Emacs images and their source in the Adwaita/scalable
directory:
left.svg ui/pan-start-symbolic.svg
right.svg ui/pan-end-symbolic.svg
up.svg ui/pan-up-symbolic.svg
+ conceal.svg actions/view-conceal-symbolic.svg
+ reveal.svg actions/view-reveal-symbolic.svg
+
+conceal.pbm and reveal.pbm are generated from the respective *.svg
+files, using the ImageMagick converter tool.
diff --git a/etc/images/conceal.pbm b/etc/images/conceal.pbm
new file mode 100644
index 00000000000..3df787d6fd6
Binary files /dev/null and b/etc/images/conceal.pbm differ
diff --git a/etc/images/conceal.svg b/etc/images/conceal.svg
new file mode 100644
index 00000000000..172b73ed3d3
--- /dev/null
+++ b/etc/images/conceal.svg
@@ -0,0 +1,4 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<svg height="16px" viewBox="0 0 16 16" width="16px"
xmlns="http://www.w3.org/2000/svg";>
+ <path d="m 1.53125 0.46875 l -1.0625 1.0625 l 14 14 l 1.0625 -1.0625 l
-2.382812 -2.382812 c 1.265624 -1.0625 2.171874 -2.496094 2.589843 -4.097657 c
-0.914062 -3.523437 -4.097656 -5.984375 -7.738281 -5.988281 c -1.367188
0.011719 -2.707031 0.371094 -3.894531 1.042969 z m 6.46875 3.53125 c 2.210938 0
4 1.789062 4 4 c -0.003906 0.800781 -0.246094 1.578125 -0.699219 2.238281 l
-1.46875 -1.46875 c 0.105469 -0.242187 0.164063 -0.503906 0.167969 -0.769531 c
0 -1.105469 -0.894531 -2 -2 -2 [...]
+</svg>
diff --git a/etc/images/reveal.pbm b/etc/images/reveal.pbm
new file mode 100644
index 00000000000..79d2f1f3307
Binary files /dev/null and b/etc/images/reveal.pbm differ
diff --git a/etc/images/reveal.svg b/etc/images/reveal.svg
new file mode 100644
index 00000000000..41ae3733a53
--- /dev/null
+++ b/etc/images/reveal.svg
@@ -0,0 +1,4 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<svg height="16px" viewBox="0 0 16 16" width="16px"
xmlns="http://www.w3.org/2000/svg";>
+ <path d="m 8 2 c -3.648438 0.003906 -6.832031 2.476562 -7.738281 6.007812
c 0.914062 3.527344 4.097656 5.988282 7.738281 5.992188 c 3.648438 -0.003906
6.832031 -2.476562 7.738281 -6.011719 c -0.914062 -3.523437 -4.097656 -5.984375
-7.738281 -5.988281 z m 0 2 c 2.210938 0 4 1.789062 4 4 s -1.789062 4 -4 4 s -4
-1.789062 -4 -4 s 1.789062 -4 4 -4 z m 0 2 c -1.105469 0 -2 0.894531 -2 2 s
0.894531 2 2 2 s 2 -0.894531 2 -2 s -0.894531 -2 -2 -2 z m 0 0" fill="#2e3436"/>
+</svg>
diff --git a/java/debug.sh b/java/debug.sh
index 8fc03d014cf..c5d40141355 100755
--- a/java/debug.sh
+++ b/java/debug.sh
@@ -104,13 +104,14 @@ if [ -z "$devices" ]; then
exit 1
fi
-if [ -z $device ]; then
- device=$devices
+if [ `wc -w <<< "$devices"` -gt 1 ] && [ -z $device ]; then
+ echo "Multiple devices are available. Please specify one with"
+ echo "the option --device and try again."
+ exit 1
fi
-if [ `wc -w <<< "$devices"` -gt 1 ] && [ -z device ]; then
- echo "Multiple devices are available. Please pick one using"
- echo "--device and try again."
+if [ -z $device ]; then
+ device=$devices
fi
echo "Looking for $package on device $device"
@@ -189,6 +190,8 @@ if [ "$attach_existing" != "yes" ]; then
package_pids=`awk -f tmp.awk <<< $package_pids`
fi
+rm tmp.awk
+
pid=$package_pids
num_pids=`wc -w <<< "$package_pids"`
diff --git a/java/org/gnu/emacs/EmacsActivity.java
b/java/org/gnu/emacs/EmacsActivity.java
index 3237f650240..66a1e41d84c 100644
--- a/java/org/gnu/emacs/EmacsActivity.java
+++ b/java/org/gnu/emacs/EmacsActivity.java
@@ -97,7 +97,7 @@ public class EmacsActivity extends Activity
}
public static void
- invalidateFocus ()
+ invalidateFocus (int whence)
{
EmacsWindow oldFocus;
@@ -144,7 +144,7 @@ public class EmacsActivity extends Activity
layout.removeView (window.view);
window = null;
- invalidateFocus ();
+ invalidateFocus (0);
}
}
@@ -172,8 +172,17 @@ public class EmacsActivity extends Activity
if (isPaused)
window.noticeIconified ();
- /* Invalidate the focus. */
- invalidateFocus ();
+ /* Invalidate the focus. Since attachWindow may be called from
+ either the main or the UI thread, post this to the UI thread. */
+
+ runOnUiThread (new Runnable () {
+ @Override
+ public void
+ run ()
+ {
+ invalidateFocus (1);
+ }
+ });
}
@Override
@@ -238,6 +247,10 @@ public class EmacsActivity extends Activity
}
super.onCreate (savedInstanceState);
+
+ /* Call `onWindowFocusChanged' to read the focus state, which fails
+ to be called after an activity is recreated. */
+ onWindowFocusChanged (false);
}
@Override
@@ -261,7 +274,7 @@ public class EmacsActivity extends Activity
isMultitask = this instanceof EmacsMultitaskActivity;
manager.removeWindowConsumer (this, isMultitask || isFinishing ());
focusedActivities.remove (this);
- invalidateFocus ();
+ invalidateFocus (2);
/* Remove this activity from the static field, lest it leak. */
if (lastFocusedActivity == this)
@@ -274,9 +287,16 @@ public class EmacsActivity extends Activity
public final void
onWindowFocusChanged (boolean isFocused)
{
- if (isFocused && !focusedActivities.contains (this))
+ /* At times and on certain versions of Android ISFOCUSED does not
+ reflect whether the window actually holds focus, so replace it
+ with the value of `hasWindowFocus'. */
+ isFocused = hasWindowFocus ();
+
+ if (isFocused)
{
- focusedActivities.add (this);
+ if (!focusedActivities.contains (this))
+ focusedActivities.add (this);
+
lastFocusedActivity = this;
/* Update the window insets as the focus change may have
@@ -291,7 +311,7 @@ public class EmacsActivity extends Activity
else
focusedActivities.remove (this);
- invalidateFocus ();
+ invalidateFocus (3);
}
@Override
diff --git a/java/org/gnu/emacs/EmacsContextMenu.java
b/java/org/gnu/emacs/EmacsContextMenu.java
index 17e6033377d..2bbf2a313d6 100644
--- a/java/org/gnu/emacs/EmacsContextMenu.java
+++ b/java/org/gnu/emacs/EmacsContextMenu.java
@@ -361,8 +361,23 @@ public final class EmacsContextMenu
public Boolean
call ()
{
+ boolean rc;
+
lastMenuEventSerial = serial;
- return display1 (window, xPosition, yPosition);
+ rc = display1 (window, xPosition, yPosition);
+
+ /* Android 3.0 to Android 7.0 perform duplicate calls to
+ onContextMenuClosed the second time a context menu is
+ dismissed. Since the second call after such a dismissal is
+ otherwise liable to prematurely cancel any context menu
+ displayed immediately afterwards, ignore calls received
+ within 150 milliseconds of this menu's being displayed. */
+
+ if (rc && Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB
+ && Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
+ wasSubmenuSelected = System.currentTimeMillis () - 150;
+
+ return rc;
}
});
diff --git a/java/org/gnu/emacs/EmacsService.java
b/java/org/gnu/emacs/EmacsService.java
index 5cb1ceca0aa..d17ba597d8e 100644
--- a/java/org/gnu/emacs/EmacsService.java
+++ b/java/org/gnu/emacs/EmacsService.java
@@ -60,6 +60,7 @@ import android.content.UriPermission;
import android.content.pm.PackageManager;
import android.content.res.AssetManager;
+import android.content.res.Configuration;
import android.hardware.input.InputManager;
@@ -135,6 +136,10 @@ public final class EmacsService extends Service
been created yet. */
private EmacsSafThread storageThread;
+ /* The Thread object representing the Android user interface
+ thread. */
+ private Thread mainThread;
+
static
{
servicingQuery = new AtomicInteger ();
@@ -235,6 +240,7 @@ public final class EmacsService extends Service
/ metrics.density)
* pixelDensityX);
resolver = getContentResolver ();
+ mainThread = Thread.currentThread ();
/* If the density used to compute the text size is lesser than
160, there's likely a bug with display density computation.
@@ -383,7 +389,13 @@ public final class EmacsService extends Service
{
if (DEBUG_THREADS)
{
- if (Thread.currentThread () instanceof EmacsThread)
+ /* When SERVICE is NULL, Emacs is being executed non-interactively. */
+ if (SERVICE == null
+ /* It was previously assumed that only instances of
+ `EmacsThread' were valid for graphics calls, but this is
+ no longer true now that Lisp threads can be attached to
+ the JVM. */
+ || (Thread.currentThread () != SERVICE.mainThread))
return;
throw new RuntimeException ("Emacs thread function"
@@ -437,21 +449,6 @@ public final class EmacsService extends Service
EmacsDrawPoint.perform (drawable, gc, x, y);
}
- public void
- clearWindow (EmacsWindow window)
- {
- checkEmacsThread ();
- window.clearWindow ();
- }
-
- public void
- clearArea (EmacsWindow window, int x, int y, int width,
- int height)
- {
- checkEmacsThread ();
- window.clearArea (x, y, width, height);
- }
-
@SuppressWarnings ("deprecation")
public void
ringBell (int duration)
@@ -581,6 +578,15 @@ public final class EmacsService extends Service
return false;
}
+ public boolean
+ detectKeyboard ()
+ {
+ Configuration configuration;
+
+ configuration = getResources ().getConfiguration ();
+ return configuration.keyboard != Configuration.KEYBOARD_NOKEYS;
+ }
+
public String
nameKeysym (int keysym)
{
@@ -905,48 +911,6 @@ public final class EmacsService extends Service
/* Content provider functions. */
- /* Return a ContentResolver capable of accessing as many files as
- possible, namely the content resolver of the last selected
- activity if available: only they posses the rights to access drag
- and drop files. */
-
- public ContentResolver
- getUsefulContentResolver ()
- {
- EmacsActivity activity;
-
- if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
- /* Since the system predates drag and drop, return this resolver
- to avoid any unforeseen difficulties. */
- return resolver;
-
- activity = EmacsActivity.lastFocusedActivity;
- if (activity == null)
- return resolver;
-
- return activity.getContentResolver ();
- }
-
- /* Return a context whose ContentResolver is granted access to most
- files, as in `getUsefulContentResolver'. */
-
- public Context
- getContentResolverContext ()
- {
- EmacsActivity activity;
-
- if (Build.VERSION.SDK_INT < Build.VERSION_CODES.N)
- /* Since the system predates drag and drop, return this resolver
- to avoid any unforeseen difficulties. */
- return this;
-
- activity = EmacsActivity.lastFocusedActivity;
- if (activity == null)
- return this;
-
- return activity;
- }
-
/* Open a content URI described by the bytes BYTES, a non-terminated
string; make it writable if WRITABLE, and readable if READABLE.
Truncate the file if TRUNCATE.
@@ -960,9 +924,6 @@ public final class EmacsService extends Service
String name, mode;
ParcelFileDescriptor fd;
int i;
- ContentResolver resolver;
-
- resolver = getUsefulContentResolver ();
/* Figure out the file access mode. */
@@ -1024,12 +985,8 @@ public final class EmacsService extends Service
ParcelFileDescriptor fd;
Uri uri;
int rc, flags;
- Context context;
- ContentResolver resolver;
ParcelFileDescriptor descriptor;
- context = getContentResolverContext ();
-
uri = Uri.parse (name);
flags = 0;
@@ -1039,7 +996,7 @@ public final class EmacsService extends Service
if (writable)
flags |= Intent.FLAG_GRANT_WRITE_URI_PERMISSION;
- rc = context.checkCallingUriPermission (uri, flags);
+ rc = checkCallingUriPermission (uri, flags);
if (rc == PackageManager.PERMISSION_GRANTED)
return true;
@@ -1053,7 +1010,6 @@ public final class EmacsService extends Service
try
{
- resolver = context.getContentResolver ();
descriptor = resolver.openFileDescriptor (uri, "r");
return true;
}
diff --git a/java/org/gnu/emacs/EmacsWindow.java
b/java/org/gnu/emacs/EmacsWindow.java
index 304304a328b..6e8bdaf7401 100644
--- a/java/org/gnu/emacs/EmacsWindow.java
+++ b/java/org/gnu/emacs/EmacsWindow.java
@@ -27,6 +27,8 @@ import java.util.HashMap;
import java.util.LinkedHashMap;
import java.util.Map;
+import android.app.Activity;
+
import android.content.ClipData;
import android.content.ClipDescription;
import android.content.Context;
@@ -240,7 +242,7 @@ public final class EmacsWindow extends EmacsHandleObject
}
}
- EmacsActivity.invalidateFocus ();
+ EmacsActivity.invalidateFocus (4);
if (!children.isEmpty ())
throw new IllegalStateException ("Trying to destroy window with "
@@ -362,6 +364,9 @@ public final class EmacsWindow extends EmacsHandleObject
requestViewLayout ();
}
+ /* Return WM layout parameters for an override redirect window with
+ the geometry provided here. */
+
private WindowManager.LayoutParams
getWindowLayoutParams ()
{
@@ -384,15 +389,15 @@ public final class EmacsWindow extends EmacsHandleObject
return params;
}
- private Context
+ private Activity
findSuitableActivityContext ()
{
/* Find a recently focused activity. */
if (!EmacsActivity.focusedActivities.isEmpty ())
return EmacsActivity.focusedActivities.get (0);
- /* Return the service context, which probably won't work. */
- return EmacsService.SERVICE;
+ /* Resort to the last activity to be focused. */
+ return EmacsActivity.lastFocusedActivity;
}
public synchronized void
@@ -416,7 +421,7 @@ public final class EmacsWindow extends EmacsHandleObject
{
EmacsWindowAttachmentManager manager;
WindowManager windowManager;
- Context ctx;
+ Activity ctx;
Object tem;
WindowManager.LayoutParams params;
@@ -447,11 +452,23 @@ public final class EmacsWindow extends EmacsHandleObject
activity using the system window manager. */
ctx = findSuitableActivityContext ();
+
+ if (ctx == null)
+ {
+ Log.w (TAG, "failed to attach override-redirect window"
+ + " for want of activity");
+ return;
+ }
+
tem = ctx.getSystemService (Context.WINDOW_SERVICE);
windowManager = (WindowManager) tem;
- /* Calculate layout parameters. */
+ /* Calculate layout parameters and propagate the
+ activity's token into it. */
+
params = getWindowLayoutParams ();
+ params.token = (ctx.findViewById (android.R.id.content)
+ .getWindowToken ());
view.setLayoutParams (params);
/* Attach the view. */
@@ -644,7 +661,7 @@ public final class EmacsWindow extends EmacsHandleObject
public void
onKeyDown (int keyCode, KeyEvent event)
{
- int state, state_1, num_lock_flag;
+ int state, state_1, extra_ignored;
long serial;
String characters;
@@ -665,23 +682,37 @@ public final class EmacsWindow extends EmacsHandleObject
state = eventModifiers (event);
- /* Num Lock and Scroll Lock aren't supported by systems older than
- Android 3.0. */
+ /* Num Lock, Scroll Lock and Meta aren't supported by systems older
+ than Android 3.0. */
if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB)
- num_lock_flag = (KeyEvent.META_NUM_LOCK_ON
- | KeyEvent.META_SCROLL_LOCK_ON);
+ extra_ignored = (KeyEvent.META_NUM_LOCK_ON
+ | KeyEvent.META_SCROLL_LOCK_ON
+ | KeyEvent.META_META_MASK);
else
- num_lock_flag = 0;
+ extra_ignored = 0;
/* Ignore meta-state understood by Emacs for now, or key presses
- such as Ctrl+C and Meta+C will not be recognized as an ASCII
- key press event. */
+ such as Ctrl+C and Meta+C will not be recognized as ASCII key
+ press events. */
state_1
= state & ~(KeyEvent.META_ALT_MASK | KeyEvent.META_CTRL_MASK
- | KeyEvent.META_SYM_ON | KeyEvent.META_META_MASK
- | num_lock_flag);
+ | KeyEvent.META_SYM_ON | extra_ignored);
+
+ /* There's no distinction between Right Alt and Alt Gr on Android,
+ so restore META_ALT_RIGHT_ON if set in state to enable composing
+ characters. (bug#69321) */
+
+ if ((state & KeyEvent.META_ALT_RIGHT_ON) != 0)
+ {
+ state_1 |= KeyEvent.META_ALT_ON | KeyEvent.META_ALT_RIGHT_ON;
+
+ /* If Alt is also not depressed, remove its bit from the mask
+ reported to Emacs. */
+ if ((state & KeyEvent.META_ALT_LEFT_ON) == 0)
+ state &= ~KeyEvent.META_ALT_MASK;
+ }
synchronized (eventStrings)
{
@@ -702,29 +733,43 @@ public final class EmacsWindow extends EmacsHandleObject
public void
onKeyUp (int keyCode, KeyEvent event)
{
- int state, state_1, unicode_char, num_lock_flag;
+ int state, state_1, unicode_char, extra_ignored;
long time;
/* Compute the event's modifier mask. */
state = eventModifiers (event);
- /* Num Lock and Scroll Lock aren't supported by systems older than
- Android 3.0. */
+ /* Num Lock, Scroll Lock and Meta aren't supported by systems older
+ than Android 3.0. */
if (Build.VERSION.SDK_INT >= Build.VERSION_CODES.HONEYCOMB)
- num_lock_flag = (KeyEvent.META_NUM_LOCK_ON
- | KeyEvent.META_SCROLL_LOCK_ON);
+ extra_ignored = (KeyEvent.META_NUM_LOCK_ON
+ | KeyEvent.META_SCROLL_LOCK_ON
+ | KeyEvent.META_META_MASK);
else
- num_lock_flag = 0;
+ extra_ignored = 0;
/* Ignore meta-state understood by Emacs for now, or key presses
- such as Ctrl+C and Meta+C will not be recognized as an ASCII
- key press event. */
+ such as Ctrl+C and Meta+C will not be recognized as ASCII key
+ press events. */
state_1
= state & ~(KeyEvent.META_ALT_MASK | KeyEvent.META_CTRL_MASK
- | KeyEvent.META_SYM_ON | KeyEvent.META_META_MASK
- | num_lock_flag);
+ | KeyEvent.META_SYM_ON | extra_ignored);
+
+ /* There's no distinction between Right Alt and Alt Gr on Android,
+ so restore META_ALT_RIGHT_ON if set in state to enable composing
+ characters. */
+
+ if ((state & KeyEvent.META_ALT_RIGHT_ON) != 0)
+ {
+ state_1 |= KeyEvent.META_ALT_ON | KeyEvent.META_ALT_RIGHT_ON;
+
+ /* If Alt is also not depressed, remove its bit from the mask
+ reported to Emacs. */
+ if ((state & KeyEvent.META_ALT_LEFT_ON) == 0)
+ state &= ~KeyEvent.META_ALT_MASK;
+ }
unicode_char = getEventUnicodeChar (event, state_1);
@@ -760,7 +805,7 @@ public final class EmacsWindow extends EmacsHandleObject
public void
onFocusChanged (boolean gainFocus)
{
- EmacsActivity.invalidateFocus ();
+ EmacsActivity.invalidateFocus (gainFocus ? 6 : 5);
}
/* Notice that the activity has been detached or destroyed.
@@ -1746,7 +1791,7 @@ public final class EmacsWindow extends EmacsHandleObject
/* Attempt to acquire permissions for this URI;
failing which, insert it as text instead. */
-
+
if (uri != null
&& uri.getScheme () != null
&& uri.getScheme ().equals ("content")
diff --git a/leim/Makefile.in b/leim/Makefile.in
index f7a23178919..bc1eeb5e634 100644
--- a/leim/Makefile.in
+++ b/leim/Makefile.in
@@ -101,11 +101,11 @@ ${leimdir}/quail ${leimdir}/ja-dic:
## All of TIT_GB and TIT_BIG5.
${leimdir}/quail/%.el: ${srcdir}/CXTERM-DIC/%.tit
$(AM_V_GEN)${RUN_EMACS} -l titdic-cnv \
- -f batch-titdic-convert -dir ${leimdir}/quail $<
+ -f batch-tit-dic-convert -dir ${leimdir}/quail $<
misc_convert = $(AM_V_GEN)${RUN_EMACS} \
- -l titdic-cnv -f batch-miscdic-convert -dir ${leimdir}/quail
+ -l titdic-cnv -f batch-tit-miscdic-convert -dir ${leimdir}/quail
## CTLau.el, CTLau-b5.el.
${leimdir}/quail/CT%.el: ${srcdir}/MISC-DIC/CT%.html
@@ -148,7 +148,7 @@ ${leimdir}/ja-dic/ja-dic.el: $(srcdir)/SKK-DIC/SKK-JISYO.L
small-ja-dic-option
-f batch-skkdic-convert -dir "$(leimdir)/ja-dic"
$(JA_DIC_NO_REDUCTION_OPTION) "$<"
${srcdir}/../lisp/language/pinyin.el: ${srcdir}/MISC-DIC/pinyin.map
- $(AM_V_GEN)${RUN_EMACS} -l titdic-cnv -f pinyin-convert $< $@
+ $(AM_V_GEN)${RUN_EMACS} -l titdic-cnv -f tit-pinyin-convert $< $@
.PHONY: bootstrap-clean distclean maintainer-clean gen-clean
diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in
index 7c059640862..3cdf1620781 100644
--- a/lib-src/Makefile.in
+++ b/lib-src/Makefile.in
@@ -319,7 +319,7 @@ maybe-blessmail: $(BLESSMAIL_TARGET)
## up if chown or chgrp fails, as the package responsible for
## installing Emacs can fix this problem later.
$(DESTDIR)${archlibdir}: all
- $(info $ )
+ $(info $.)
$(info Installing utilities run internally by Emacs.)
umask 022 && ${MKDIR_P} "$(DESTDIR)${archlibdir}"
exp_archlibdir=`cd "$(DESTDIR)${archlibdir}" && pwd -P` && \
@@ -361,7 +361,7 @@ $(DESTDIR)${archlibdir}: all
.PHONY: bootstrap-clean check tags
install: $(DESTDIR)${archlibdir}
- $(info $ )
+ $(info $.)
$(info Installing utilities for users to run.)
umask 022 && ${MKDIR_P} "$(DESTDIR)${bindir}"
for file in ${INSTALLABLES} ; do \
diff --git a/lib/cdefs.h b/lib/cdefs.h
index 87ddce319dc..d38382ad9d8 100644
--- a/lib/cdefs.h
+++ b/lib/cdefs.h
@@ -42,8 +42,8 @@
#if (defined __has_attribute \
&& (!defined __clang_minor__ \
|| (defined __apple_build_version__ \
- ? 6000000 <= __apple_build_version__ \
- : 3 < __clang_major__ + (5 <= __clang_minor__))))
+ ? 7000000 <= __apple_build_version__ \
+ : 5 <= __clang_major__)))
# define __glibc_has_attribute(attr) __has_attribute (attr)
#else
# define __glibc_has_attribute(attr) 0
diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in
index fcf2b186038..711ddcf1260 100644
--- a/lib/gnulib.mk.in
+++ b/lib/gnulib.mk.in
@@ -47,6 +47,7 @@
# --avoid=iswdigit \
# --avoid=iswxdigit \
# --avoid=langinfo \
+# --avoid=localename-unsafe-limited \
# --avoid=lock \
# --avoid=mbrtowc \
# --avoid=mbsinit \
@@ -1185,6 +1186,7 @@ REPLACE_MB_CUR_MAX = @REPLACE_MB_CUR_MAX@
REPLACE_MEMCHR = @REPLACE_MEMCHR@
REPLACE_MEMMEM = @REPLACE_MEMMEM@
REPLACE_MEMPCPY = @REPLACE_MEMPCPY@
+REPLACE_MEMSET_EXPLICIT = @REPLACE_MEMSET_EXPLICIT@
REPLACE_MKDIR = @REPLACE_MKDIR@
REPLACE_MKFIFO = @REPLACE_MKFIFO@
REPLACE_MKFIFOAT = @REPLACE_MKFIFOAT@
@@ -1271,6 +1273,7 @@ REPLACE_SYMLINKAT = @REPLACE_SYMLINKAT@
REPLACE_TIME = @REPLACE_TIME@
REPLACE_TIMEGM = @REPLACE_TIMEGM@
REPLACE_TIMESPEC_GET = @REPLACE_TIMESPEC_GET@
+REPLACE_TIMESPEC_GETRES = @REPLACE_TIMESPEC_GETRES@
REPLACE_TMPFILE = @REPLACE_TMPFILE@
REPLACE_TRUNCATE = @REPLACE_TRUNCATE@
REPLACE_TTYNAME_R = @REPLACE_TTYNAME_R@
@@ -2743,7 +2746,9 @@ ifeq (,$(OMIT_GNULIB_MODULE_nstrftime))
libgnu_a_SOURCES += nstrftime.c
-EXTRA_DIST += strftime.h
+EXTRA_DIST += strftime.c strftime.h
+
+EXTRA_libgnu_a_SOURCES += strftime.c
endif
## end gnulib module nstrftime
@@ -3560,6 +3565,7 @@ string.h: string.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H
-e 's|@''REPLACE_MEMCHR''@|$(REPLACE_MEMCHR)|g' \
-e 's|@''REPLACE_MEMMEM''@|$(REPLACE_MEMMEM)|g' \
-e 's|@''REPLACE_MEMPCPY''@|$(REPLACE_MEMPCPY)|g' \
+ -e 's|@''REPLACE_MEMSET_EXPLICIT''@|$(REPLACE_MEMSET_EXPLICIT)|g'
\
-e 's|@''REPLACE_FREE''@|$(REPLACE_FREE)|g' \
-e 's|@''REPLACE_STPCPY''@|$(REPLACE_STPCPY)|g' \
-e 's|@''REPLACE_STPNCPY''@|$(REPLACE_STPNCPY)|g' \
@@ -3892,6 +3898,7 @@ time.h: time.in.h $(top_builddir)/config.status
$(CXXDEFS_H) $(ARG_NONNULL_H) $(
-e 's|@''REPLACE_TIME''@|$(REPLACE_TIME)|g' \
-e 's|@''REPLACE_TIMEGM''@|$(REPLACE_TIMEGM)|g' \
-e 's|@''REPLACE_TIMESPEC_GET''@|$(REPLACE_TIMESPEC_GET)|g' \
+ -e 's|@''REPLACE_TIMESPEC_GETRES''@|$(REPLACE_TIMESPEC_GETRES)|g'
\
-e 's|@''REPLACE_TZSET''@|$(REPLACE_TZSET)|g' \
-e
's|@''PTHREAD_H_DEFINES_STRUCT_TIMESPEC''@|$(PTHREAD_H_DEFINES_STRUCT_TIMESPEC)|g'
\
-e
's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g'
\
diff --git a/lib/limits.in.h b/lib/limits.in.h
index 236fc58e525..c65eb4c1cfe 100644
--- a/lib/limits.in.h
+++ b/lib/limits.in.h
@@ -130,7 +130,7 @@
# define BOOL_WIDTH 1
# define BOOL_MAX 1
# elif ! defined BOOL_MAX
-# define BOOL_MAX ((((1U << (BOOL_WIDTH - 1)) - 1) << 1) + 1)
+# define BOOL_MAX 1
# endif
#endif
diff --git a/lib/nstrftime.c b/lib/nstrftime.c
index 69e4164dc0c..88490064297 100644
--- a/lib/nstrftime.c
+++ b/lib/nstrftime.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1991-2024 Free Software Foundation, Inc.
- This file is part of the GNU C Library.
+/* Generate time strings.
+
+ Copyright (C) 2024 Free Software Foundation, Inc.
This file is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
@@ -14,1497 +15,5 @@
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>. */
-#ifdef _LIBC
-# define USE_IN_EXTENDED_LOCALE_MODEL 1
-# define HAVE_STRUCT_ERA_ENTRY 1
-# define HAVE_TM_GMTOFF 1
-# define HAVE_STRUCT_TM_TM_ZONE 1
-# define HAVE_TZNAME 1
-# include "../locale/localeinfo.h"
-#else
-# include <libc-config.h>
-# if FPRINTFTIME
-# include "fprintftime.h"
-# else
-# include "strftime.h"
-# endif
-# include "time-internal.h"
-#endif
-
-#include <ctype.h>
-#include <errno.h>
-#include <time.h>
-
-#if HAVE_TZNAME && !HAVE_DECL_TZNAME
-extern char *tzname[];
-#endif
-
-/* Do multibyte processing if multibyte encodings are supported, unless
- multibyte sequences are safe in formats. Multibyte sequences are
- safe if they cannot contain byte sequences that look like format
- conversion specifications. The multibyte encodings used by the
- C library on the various platforms (UTF-8, GB2312, GBK, CP936,
- GB18030, EUC-TW, BIG5, BIG5-HKSCS, CP950, EUC-JP, EUC-KR, CP949,
- SHIFT_JIS, CP932, JOHAB) are safe for formats, because the byte '%'
- cannot occur in a multibyte character except in the first byte.
-
- The DEC-HANYU encoding used on OSF/1 is not safe for formats, but
- this encoding has never been seen in real-life use, so we ignore
- it. */
-#if !(defined __osf__ && 0)
-# define MULTIBYTE_IS_FORMAT_SAFE 1
-#endif
-#define DO_MULTIBYTE (! MULTIBYTE_IS_FORMAT_SAFE)
-
-#if DO_MULTIBYTE
-# include <wchar.h>
- static const mbstate_t mbstate_zero;
-#endif
-
-#include <limits.h>
-#include <stdckdint.h>
-#include <stddef.h>
-#include <stdlib.h>
-#include <string.h>
-
-#include "attribute.h"
-#include <intprops.h>
-
-#ifdef COMPILE_WIDE
-# include <endian.h>
-# define CHAR_T wchar_t
-# define UCHAR_T unsigned int
-# define L_(Str) L##Str
-# define NLW(Sym) _NL_W##Sym
-
-# define MEMCPY(d, s, n) __wmemcpy (d, s, n)
-# define STRLEN(s) __wcslen (s)
-
-#else
-# define CHAR_T char
-# define UCHAR_T unsigned char
-# define L_(Str) Str
-# define NLW(Sym) Sym
-# define ABALTMON_1 _NL_ABALTMON_1
-
-# define MEMCPY(d, s, n) memcpy (d, s, n)
-# define STRLEN(s) strlen (s)
-
-#endif
-
-/* Shift A right by B bits portably, by dividing A by 2**B and
- truncating towards minus infinity. A and B should be free of side
- effects, and B should be in the range 0 <= B <= INT_BITS - 2, where
- INT_BITS is the number of useful bits in an int. GNU code can
- assume that INT_BITS is at least 32.
-
- ISO C99 says that A >> B is implementation-defined if A < 0. Some
- implementations (e.g., UNICOS 9.0 on a Cray Y-MP EL) don't shift
- right in the usual way when A < 0, so SHR falls back on division if
- ordinary A >> B doesn't seem to be the usual signed shift. */
-#define SHR(a, b) \
- (-1 >> 1 == -1 \
- ? (a) >> (b) \
- : ((a) + ((a) < 0)) / (1 << (b)) - ((a) < 0))
-
-#define TM_YEAR_BASE 1900
-
-#ifndef __isleap
-/* Nonzero if YEAR is a leap year (every 4 years,
- except every 100th isn't, and every 400th is). */
-# define __isleap(year) \
- ((year) % 4 == 0 && ((year) % 100 != 0 || (year) % 400 == 0))
-#endif
-
-
-#ifdef _LIBC
-# define mktime_z(tz, tm) mktime (tm)
-# define tzname __tzname
-# define tzset __tzset
-#endif
-
-#ifndef FPRINTFTIME
-# define FPRINTFTIME 0
-#endif
-
-#if FPRINTFTIME
-# define STREAM_OR_CHAR_T FILE
-# define STRFTIME_ARG(x) /* empty */
-#else
-# define STREAM_OR_CHAR_T CHAR_T
-# define STRFTIME_ARG(x) x,
-#endif
-
-#if FPRINTFTIME
-# define memset_byte(P, Len, Byte) \
- do { size_t _i; for (_i = 0; _i < Len; _i++) fputc (Byte, P); } while (0)
-# define memset_space(P, Len) memset_byte (P, Len, ' ')
-# define memset_zero(P, Len) memset_byte (P, Len, '0')
-#elif defined COMPILE_WIDE
-# define memset_space(P, Len) (wmemset (P, L' ', Len), (P) += (Len))
-# define memset_zero(P, Len) (wmemset (P, L'0', Len), (P) += (Len))
-#else
-# define memset_space(P, Len) (memset (P, ' ', Len), (P) += (Len))
-# define memset_zero(P, Len) (memset (P, '0', Len), (P) += (Len))
-#endif
-
-#if FPRINTFTIME
-# define advance(P, N)
-#else
-# define advance(P, N) ((P) += (N))
-#endif
-
-#define add(n, f) width_add (width, n, f)
-#define width_add(width, n, f) \
- do \
- { \
- size_t _n = (n); \
- size_t _w = pad == L_('-') || width < 0 ? 0 : width; \
- size_t _incr = _n < _w ? _w : _n; \
- if (_incr >= maxsize - i) \
- { \
- errno = ERANGE; \
- return 0; \
- } \
- if (p) \
- { \
- if (_n < _w) \
- { \
- size_t _delta = _w - _n; \
- if (pad == L_('0') || pad == L_('+')) \
- memset_zero (p, _delta); \
- else \
- memset_space (p, _delta); \
- } \
- f; \
- advance (p, _n); \
- } \
- i += _incr; \
- } while (0)
-
-#define add1(c) width_add1 (width, c)
-#if FPRINTFTIME
-# define width_add1(width, c) width_add (width, 1, fputc (c, p))
-#else
-# define width_add1(width, c) width_add (width, 1, *p = c)
-#endif
-
-#define cpy(n, s) width_cpy (width, n, s)
-#if FPRINTFTIME
-# define width_cpy(width, n, s) \
- width_add (width, n, \
- do \
- { \
- if (to_lowcase) \
- fwrite_lowcase (p, (s), _n); \
- else if (to_uppcase) \
- fwrite_uppcase (p, (s), _n); \
- else \
- { \
- /* Ignore the value of fwrite. The caller can determine whether \
- an error occurred by inspecting ferror (P). All known fwrite \
- implementations set the stream's error indicator when they \
- fail due to ENOMEM etc., even though C11 and POSIX.1-2008 do \
- not require this. */ \
- fwrite (s, _n, 1, p); \
- } \
- } \
- while (0) \
- )
-#else
-# define width_cpy(width, n, s) \
- width_add (width, n, \
- if (to_lowcase) \
- memcpy_lowcase (p, (s), _n LOCALE_ARG); \
- else if (to_uppcase) \
- memcpy_uppcase (p, (s), _n LOCALE_ARG); \
- else \
- MEMCPY ((void *) p, (void const *) (s), _n))
-#endif
-
-#ifdef COMPILE_WIDE
-# ifndef USE_IN_EXTENDED_LOCALE_MODEL
-# undef __mbsrtowcs_l
-# define __mbsrtowcs_l(d, s, l, st, loc) __mbsrtowcs (d, s, l, st)
-# endif
-#endif
-
-
-#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
-/* We use this code also for the extended locale handling where the
- function gets as an additional argument the locale which has to be
- used. To access the values we have to redefine the _NL_CURRENT
- macro. */
-# define strftime __strftime_l
-# define wcsftime __wcsftime_l
-# undef _NL_CURRENT
-# define _NL_CURRENT(category, item) \
- (current->values[_NL_ITEM_INDEX (item)].string)
-# define LOCALE_PARAM , locale_t loc
-# define LOCALE_ARG , loc
-# define HELPER_LOCALE_ARG , current
-#else
-# define LOCALE_PARAM
-# define LOCALE_ARG
-# ifdef _LIBC
-# define HELPER_LOCALE_ARG , _NL_CURRENT_DATA (LC_TIME)
-# else
-# define HELPER_LOCALE_ARG
-# endif
-#endif
-
-#ifdef COMPILE_WIDE
-# ifdef USE_IN_EXTENDED_LOCALE_MODEL
-# define TOUPPER(Ch, L) __towupper_l (Ch, L)
-# define TOLOWER(Ch, L) __towlower_l (Ch, L)
-# else
-# define TOUPPER(Ch, L) towupper (Ch)
-# define TOLOWER(Ch, L) towlower (Ch)
-# endif
-#else
-# ifdef USE_IN_EXTENDED_LOCALE_MODEL
-# define TOUPPER(Ch, L) __toupper_l (Ch, L)
-# define TOLOWER(Ch, L) __tolower_l (Ch, L)
-# else
-# define TOUPPER(Ch, L) toupper (Ch)
-# define TOLOWER(Ch, L) tolower (Ch)
-# endif
-#endif
-/* We don't use 'isdigit' here since the locale dependent
- interpretation is not what we want here. We only need to accept
- the arabic digits in the ASCII range. One day there is perhaps a
- more reliable way to accept other sets of digits. */
-#define ISDIGIT(Ch) ((unsigned int) (Ch) - L_('0') <= 9)
-
-/* Avoid false GCC warning "'memset' specified size 18446744073709551615
exceeds
- maximum object size 9223372036854775807", caused by insufficient data flow
- analysis and value propagation of the 'width_add' expansion when GCC is not
- optimizing. Cf. <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=88443>. */
-#if __GNUC__ >= 7 && !__OPTIMIZE__
-# pragma GCC diagnostic ignored "-Wstringop-overflow"
-#endif
-
-#if FPRINTFTIME
-static void
-fwrite_lowcase (FILE *fp, const CHAR_T *src, size_t len)
-{
- while (len-- > 0)
- {
- fputc (TOLOWER ((UCHAR_T) *src, loc), fp);
- ++src;
- }
-}
-
-static void
-fwrite_uppcase (FILE *fp, const CHAR_T *src, size_t len)
-{
- while (len-- > 0)
- {
- fputc (TOUPPER ((UCHAR_T) *src, loc), fp);
- ++src;
- }
-}
-#else
-static CHAR_T *memcpy_lowcase (CHAR_T *dest, const CHAR_T *src,
- size_t len LOCALE_PARAM);
-
-static CHAR_T *
-memcpy_lowcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
-{
- while (len-- > 0)
- dest[len] = TOLOWER ((UCHAR_T) src[len], loc);
- return dest;
-}
-
-static CHAR_T *memcpy_uppcase (CHAR_T *dest, const CHAR_T *src,
- size_t len LOCALE_PARAM);
-
-static CHAR_T *
-memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM)
-{
- while (len-- > 0)
- dest[len] = TOUPPER ((UCHAR_T) src[len], loc);
- return dest;
-}
-#endif
-
-
-#if ! HAVE_TM_GMTOFF
-/* Yield the difference between *A and *B,
- measured in seconds, ignoring leap seconds. */
-# define tm_diff ftime_tm_diff
-static int tm_diff (const struct tm *, const struct tm *);
-static int
-tm_diff (const struct tm *a, const struct tm *b)
-{
- /* Compute intervening leap days correctly even if year is negative.
- Take care to avoid int overflow in leap day calculations,
- but it's OK to assume that A and B are close to each other. */
- int a4 = SHR (a->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (a->tm_year & 3);
- int b4 = SHR (b->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (b->tm_year & 3);
- int a100 = (a4 + (a4 < 0)) / 25 - (a4 < 0);
- int b100 = (b4 + (b4 < 0)) / 25 - (b4 < 0);
- int a400 = SHR (a100, 2);
- int b400 = SHR (b100, 2);
- int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400);
- int years = a->tm_year - b->tm_year;
- int days = (365 * years + intervening_leap_days
- + (a->tm_yday - b->tm_yday));
- return (60 * (60 * (24 * days + (a->tm_hour - b->tm_hour))
- + (a->tm_min - b->tm_min))
- + (a->tm_sec - b->tm_sec));
-}
-#endif /* ! HAVE_TM_GMTOFF */
-
-
-
-/* The number of days from the first day of the first ISO week of this
- year to the year day YDAY with week day WDAY. ISO weeks start on
- Monday; the first ISO week has the year's first Thursday. YDAY may
- be as small as YDAY_MINIMUM. */
-#define ISO_WEEK_START_WDAY 1 /* Monday */
-#define ISO_WEEK1_WDAY 4 /* Thursday */
-#define YDAY_MINIMUM (-366)
-static int iso_week_days (int, int);
-static __inline int
-iso_week_days (int yday, int wday)
-{
- /* Add enough to the first operand of % to make it nonnegative. */
- int big_enough_multiple_of_7 = (-YDAY_MINIMUM / 7 + 2) * 7;
- return (yday
- - (yday - wday + ISO_WEEK1_WDAY + big_enough_multiple_of_7) % 7
- + ISO_WEEK1_WDAY - ISO_WEEK_START_WDAY);
-}
-
-
-/* When compiling this file, GNU applications can #define my_strftime
- to a symbol (typically nstrftime) to get an extended strftime with
- extra arguments TZ and NS. */
-
-#if FPRINTFTIME
-# undef my_strftime
-# define my_strftime fprintftime
-#endif
-
-#ifdef my_strftime
-# define extra_args , tz, ns
-# define extra_args_spec , timezone_t tz, int ns
-#else
-# if defined COMPILE_WIDE
-# define my_strftime wcsftime
-# define nl_get_alt_digit _nl_get_walt_digit
-# else
-# define my_strftime strftime
-# define nl_get_alt_digit _nl_get_alt_digit
-# endif
-# define extra_args
-# define extra_args_spec
-/* We don't have this information in general. */
-# define tz 1
-# define ns 0
-#endif
-
-static size_t __strftime_internal (STREAM_OR_CHAR_T *, STRFTIME_ARG (size_t)
- const CHAR_T *, const struct tm *,
- bool, int, int, bool *
- extra_args_spec LOCALE_PARAM);
-
-/* Write information from TP into S according to the format
- string FORMAT, writing no more that MAXSIZE characters
- (including the terminating '\0') and returning number of
- characters written. If S is NULL, nothing will be written
- anywhere, so to determine how many characters would be
- written, use NULL for S and (size_t) -1 for MAXSIZE. */
-size_t
-my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
- const CHAR_T *format,
- const struct tm *tp extra_args_spec LOCALE_PARAM)
-{
- bool tzset_called = false;
- return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp, false,
- 0, -1, &tzset_called extra_args LOCALE_ARG);
-}
-libc_hidden_def (my_strftime)
-
-/* Just like my_strftime, above, but with more parameters.
- UPCASE indicates that the result should be converted to upper case.
- YR_SPEC and WIDTH specify the padding and width for the year.
- *TZSET_CALLED indicates whether tzset has been called here. */
-static size_t
-__strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize)
- const CHAR_T *format,
- const struct tm *tp, bool upcase,
- int yr_spec, int width, bool *tzset_called
- extra_args_spec LOCALE_PARAM)
-{
-#if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL
- struct __locale_data *const current = loc->__locales[LC_TIME];
-#endif
-#if FPRINTFTIME
- size_t maxsize = (size_t) -1;
-#endif
-
- int saved_errno = errno;
- int hour12 = tp->tm_hour;
-#ifdef _NL_CURRENT
- /* We cannot make the following values variables since we must delay
- the evaluation of these values until really needed since some
- expressions might not be valid in every situation. The 'struct tm'
- might be generated by a strptime() call that initialized
- only a few elements. Dereference the pointers only if the format
- requires this. Then it is ok to fail if the pointers are invalid. */
-# define a_wkday \
- ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(ABDAY_1) +
tp->tm_wday)))
-# define f_wkday \
- ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(DAY_1) + tp->tm_wday)))
-# define a_month \
- ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(ABMON_1) + tp->tm_mon)))
-# define f_month \
- ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(MON_1) + tp->tm_mon)))
-# define a_altmonth \
- ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(ABALTMON_1) +
tp->tm_mon)))
-# define f_altmonth \
- ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \
- ? "?" : _NL_CURRENT (LC_TIME, NLW(ALTMON_1) +
tp->tm_mon)))
-# define ampm \
- ((const CHAR_T *) _NL_CURRENT (LC_TIME, tp->tm_hour > 11 \
- ? NLW(PM_STR) : NLW(AM_STR)))
-
-# define aw_len STRLEN (a_wkday)
-# define am_len STRLEN (a_month)
-# define aam_len STRLEN (a_altmonth)
-# define ap_len STRLEN (ampm)
-#endif
-#if HAVE_TZNAME
- char **tzname_vec = tzname;
-#endif
- const char *zone;
- size_t i = 0;
- STREAM_OR_CHAR_T *p = s;
- const CHAR_T *f;
-#if DO_MULTIBYTE && !defined COMPILE_WIDE
- const char *format_end = NULL;
-#endif
-
- zone = NULL;
-#if HAVE_STRUCT_TM_TM_ZONE
- /* The POSIX test suite assumes that setting
- the environment variable TZ to a new value before calling strftime()
- will influence the result (the %Z format) even if the information in
- TP is computed with a totally different time zone.
- This is bogus: though POSIX allows bad behavior like this,
- POSIX does not require it. Do the right thing instead. */
- zone = (const char *) tp->tm_zone;
-#endif
-#if HAVE_TZNAME
- if (!tz)
- {
- if (! (zone && *zone))
- zone = "GMT";
- }
- else
- {
-# if !HAVE_STRUCT_TM_TM_ZONE
- /* Infer the zone name from *TZ instead of from TZNAME. */
- tzname_vec = tz->tzname_copy;
-# endif
- }
- /* The tzset() call might have changed the value. */
- if (!(zone && *zone) && tp->tm_isdst >= 0)
- {
- /* POSIX.1 requires that local time zone information be used as
- though strftime called tzset. */
-# ifndef my_strftime
- if (!*tzset_called)
- {
- tzset ();
- *tzset_called = true;
- }
-# endif
- zone = tzname_vec[tp->tm_isdst != 0];
- }
-#endif
- if (! zone)
- zone = "";
-
- if (hour12 > 12)
- hour12 -= 12;
- else
- if (hour12 == 0)
- hour12 = 12;
-
- for (f = format; *f != '\0'; width = -1, f++)
- {
- int pad = 0; /* Padding for number ('_', '-', '+', '0', or 0). */
- int modifier; /* Field modifier ('E', 'O', or 0). */
- int digits = 0; /* Max digits for numeric format. */
- int number_value; /* Numeric value to be printed. */
- unsigned int u_number_value; /* (unsigned int) number_value. */
- bool negative_number; /* The number is negative. */
- bool always_output_a_sign; /* +/- should always be output. */
- int tz_colon_mask; /* Bitmask of where ':' should appear. */
- const CHAR_T *subfmt;
- CHAR_T *bufp;
- CHAR_T buf[1
- + 2 /* for the two colons in a %::z or %:::z time zone */
- + (sizeof (int) < sizeof (time_t)
- ? INT_STRLEN_BOUND (time_t)
- : INT_STRLEN_BOUND (int))];
- bool to_lowcase = false;
- bool to_uppcase = upcase;
- size_t colons;
- bool change_case = false;
- int format_char;
- int subwidth;
-
-#if DO_MULTIBYTE && !defined COMPILE_WIDE
- switch (*f)
- {
- case L_('%'):
- break;
-
- case L_('\b'): case L_('\t'): case L_('\n'):
- case L_('\v'): case L_('\f'): case L_('\r'):
- case L_(' '): case L_('!'): case L_('"'): case L_('#'): case L_('&'):
- case L_('\''): case L_('('): case L_(')'): case L_('*'): case L_('+'):
- case L_(','): case L_('-'): case L_('.'): case L_('/'): case L_('0'):
- case L_('1'): case L_('2'): case L_('3'): case L_('4'): case L_('5'):
- case L_('6'): case L_('7'): case L_('8'): case L_('9'): case L_(':'):
- case L_(';'): case L_('<'): case L_('='): case L_('>'): case L_('?'):
- case L_('A'): case L_('B'): case L_('C'): case L_('D'): case L_('E'):
- case L_('F'): case L_('G'): case L_('H'): case L_('I'): case L_('J'):
- case L_('K'): case L_('L'): case L_('M'): case L_('N'): case L_('O'):
- case L_('P'): case L_('Q'): case L_('R'): case L_('S'): case L_('T'):
- case L_('U'): case L_('V'): case L_('W'): case L_('X'): case L_('Y'):
- case L_('Z'): case L_('['): case L_('\\'): case L_(']'): case L_('^'):
- case L_('_'): case L_('a'): case L_('b'): case L_('c'): case L_('d'):
- case L_('e'): case L_('f'): case L_('g'): case L_('h'): case L_('i'):
- case L_('j'): case L_('k'): case L_('l'): case L_('m'): case L_('n'):
- case L_('o'): case L_('p'): case L_('q'): case L_('r'): case L_('s'):
- case L_('t'): case L_('u'): case L_('v'): case L_('w'): case L_('x'):
- case L_('y'): case L_('z'): case L_('{'): case L_('|'): case L_('}'):
- case L_('~'):
- /* The C Standard requires these 98 characters (plus '%') to
- be in the basic execution character set. None of these
- characters can start a multibyte sequence, so they need
- not be analyzed further. */
- add1 (*f);
- continue;
-
- default:
- /* Copy this multibyte sequence until we reach its end, find
- an error, or come back to the initial shift state. */
- {
- mbstate_t mbstate = mbstate_zero;
- size_t len = 0;
- size_t fsize;
-
- if (! format_end)
- format_end = f + strlen (f) + 1;
- fsize = format_end - f;
-
- do
- {
- size_t bytes = mbrlen (f + len, fsize - len, &mbstate);
-
- if (bytes == 0)
- break;
-
- if (bytes == (size_t) -2)
- {
- len += strlen (f + len);
- break;
- }
-
- if (bytes == (size_t) -1)
- {
- len++;
- break;
- }
-
- len += bytes;
- }
- while (! mbsinit (&mbstate));
-
- cpy (len, f);
- f += len - 1;
- continue;
- }
- }
-
-#else /* ! DO_MULTIBYTE */
-
- /* Either multibyte encodings are not supported, they are
- safe for formats, so any non-'%' byte can be copied through,
- or this is the wide character version. */
- if (*f != L_('%'))
- {
- add1 (*f);
- continue;
- }
-
-#endif /* ! DO_MULTIBYTE */
-
- char const *percent = f;
-
- /* Check for flags that can modify a format. */
- while (1)
- {
- switch (*++f)
- {
- /* This influences the number formats. */
- case L_('_'):
- case L_('-'):
- case L_('+'):
- case L_('0'):
- pad = *f;
- continue;
-
- /* This changes textual output. */
- case L_('^'):
- to_uppcase = true;
- continue;
- case L_('#'):
- change_case = true;
- continue;
-
- default:
- break;
- }
- break;
- }
-
- if (ISDIGIT (*f))
- {
- width = 0;
- do
- {
- if (ckd_mul (&width, width, 10)
- || ckd_add (&width, width, *f - L_('0')))
- width = INT_MAX;
- ++f;
- }
- while (ISDIGIT (*f));
- }
-
- /* Check for modifiers. */
- switch (*f)
- {
- case L_('E'):
- case L_('O'):
- modifier = *f++;
- break;
-
- default:
- modifier = 0;
- break;
- }
-
- /* Now do the specified format. */
- format_char = *f;
- switch (format_char)
- {
-#define DO_NUMBER(d, v) \
- do \
- { \
- digits = d; \
- number_value = v; \
- goto do_number; \
- } \
- while (0)
-#define DO_SIGNED_NUMBER(d, negative, v) \
- DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_signed_number)
-#define DO_YEARISH(d, negative, v) \
- DO_MAYBE_SIGNED_NUMBER (d, negative, v, do_yearish)
-#define DO_MAYBE_SIGNED_NUMBER(d, negative, v, label) \
- do \
- { \
- digits = d; \
- negative_number = negative; \
- u_number_value = v; \
- goto label; \
- } \
- while (0)
-
- /* The mask is not what you might think.
- When the ordinal i'th bit is set, insert a colon
- before the i'th digit of the time zone representation. */
-#define DO_TZ_OFFSET(d, mask, v) \
- do \
- { \
- digits = d; \
- tz_colon_mask = mask; \
- u_number_value = v; \
- goto do_tz_offset; \
- } \
- while (0)
-#define DO_NUMBER_SPACEPAD(d, v) \
- do \
- { \
- digits = d; \
- number_value = v; \
- goto do_number_spacepad; \
- } \
- while (0)
-
- case L_('%'):
- if (f - 1 != percent)
- goto bad_percent;
- add1 (*f);
- break;
-
- case L_('a'):
- if (modifier != 0)
- goto bad_format;
- if (change_case)
- {
- to_uppcase = true;
- to_lowcase = false;
- }
-#ifdef _NL_CURRENT
- cpy (aw_len, a_wkday);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case 'A':
- if (modifier != 0)
- goto bad_format;
- if (change_case)
- {
- to_uppcase = true;
- to_lowcase = false;
- }
-#ifdef _NL_CURRENT
- cpy (STRLEN (f_wkday), f_wkday);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('b'):
- case L_('h'):
- if (change_case)
- {
- to_uppcase = true;
- to_lowcase = false;
- }
- if (modifier == L_('E'))
- goto bad_format;
-#ifdef _NL_CURRENT
- if (modifier == L_('O'))
- cpy (aam_len, a_altmonth);
- else
- cpy (am_len, a_month);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('B'):
- if (modifier == L_('E'))
- goto bad_format;
- if (change_case)
- {
- to_uppcase = true;
- to_lowcase = false;
- }
-#ifdef _NL_CURRENT
- if (modifier == L_('O'))
- cpy (STRLEN (f_altmonth), f_altmonth);
- else
- cpy (STRLEN (f_month), f_month);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('c'):
- if (modifier == L_('O'))
- goto bad_format;
-#ifdef _NL_CURRENT
- if (! (modifier == L_('E')
- && (*(subfmt =
- (const CHAR_T *) _NL_CURRENT (LC_TIME,
- NLW(ERA_D_T_FMT)))
- != '\0')))
- subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_T_FMT));
-#else
- goto underlying_strftime;
-#endif
-
- subformat:
- subwidth = -1;
- subformat_width:
- {
- size_t len = __strftime_internal (NULL, STRFTIME_ARG ((size_t) -1)
- subfmt, tp, to_uppcase,
- pad, subwidth, tzset_called
- extra_args LOCALE_ARG);
- add (len, __strftime_internal (p,
- STRFTIME_ARG (maxsize - i)
- subfmt, tp, to_uppcase,
- pad, subwidth, tzset_called
- extra_args LOCALE_ARG));
- }
- break;
-
-#if !(defined _NL_CURRENT && HAVE_STRUCT_ERA_ENTRY)
- underlying_strftime:
- {
- /* The relevant information is available only via the
- underlying strftime implementation, so use that. */
- char ufmt[5];
- char *u = ufmt;
- char ubuf[1024]; /* enough for any single format in practice */
- size_t len;
- /* Make sure we're calling the actual underlying strftime.
- In some cases, config.h contains something like
- "#define strftime rpl_strftime". */
-# ifdef strftime
-# undef strftime
- size_t strftime ();
-# endif
-
- /* The space helps distinguish strftime failure from empty
- output. */
- *u++ = ' ';
- *u++ = '%';
- if (modifier != 0)
- *u++ = modifier;
- *u++ = format_char;
- *u = '\0';
- len = strftime (ubuf, sizeof ubuf, ufmt, tp);
- if (len != 0)
- cpy (len - 1, ubuf + 1);
- }
- break;
-#endif
-
- case L_('C'):
- if (modifier == L_('E'))
- {
-#if HAVE_STRUCT_ERA_ENTRY
- struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
- if (era)
- {
-# ifdef COMPILE_WIDE
- size_t len = __wcslen (era->era_wname);
- cpy (len, era->era_wname);
-# else
- size_t len = strlen (era->era_name);
- cpy (len, era->era_name);
-# endif
- break;
- }
-#else
- goto underlying_strftime;
-#endif
- }
-
- {
- bool negative_year = tp->tm_year < - TM_YEAR_BASE;
- bool zero_thru_1899 = !negative_year & (tp->tm_year < 0);
- int century = ((tp->tm_year - 99 * zero_thru_1899) / 100
- + TM_YEAR_BASE / 100);
- DO_YEARISH (2, negative_year, century);
- }
-
- case L_('x'):
- if (modifier == L_('O'))
- goto bad_format;
-#ifdef _NL_CURRENT
- if (! (modifier == L_('E')
- && (*(subfmt =
- (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_D_FMT)))
- != L_('\0'))))
- subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_FMT));
- goto subformat;
-#else
- goto underlying_strftime;
-#endif
- case L_('D'):
- if (modifier != 0)
- goto bad_format;
- subfmt = L_("%m/%d/%y");
- goto subformat;
-
- case L_('d'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, tp->tm_mday);
-
- case L_('e'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER_SPACEPAD (2, tp->tm_mday);
-
- /* All numeric formats set DIGITS and NUMBER_VALUE (or
U_NUMBER_VALUE)
- and then jump to one of these labels. */
-
- do_tz_offset:
- always_output_a_sign = true;
- goto do_number_body;
-
- do_yearish:
- if (pad == 0)
- pad = yr_spec;
- always_output_a_sign
- = (pad == L_('+')
- && ((digits == 2 ? 99 : 9999) < u_number_value
- || digits < width));
- goto do_maybe_signed_number;
-
- do_number_spacepad:
- if (pad == 0)
- pad = L_('_');
-
- do_number:
- /* Format NUMBER_VALUE according to the MODIFIER flag. */
- negative_number = number_value < 0;
- u_number_value = number_value;
-
- do_signed_number:
- always_output_a_sign = false;
-
- do_maybe_signed_number:
- tz_colon_mask = 0;
-
- do_number_body:
- /* Format U_NUMBER_VALUE according to the MODIFIER flag.
- NEGATIVE_NUMBER is nonzero if the original number was
- negative; in this case it was converted directly to
- unsigned int (i.e., modulo (UINT_MAX + 1)) without
- negating it. */
- if (modifier == L_('O') && !negative_number)
- {
-#ifdef _NL_CURRENT
- /* Get the locale specific alternate representation of
- the number. If none exist NULL is returned. */
- const CHAR_T *cp = nl_get_alt_digit (u_number_value
- HELPER_LOCALE_ARG);
-
- if (cp != NULL)
- {
- size_t digitlen = STRLEN (cp);
- if (digitlen != 0)
- {
- cpy (digitlen, cp);
- break;
- }
- }
-#else
- goto underlying_strftime;
-#endif
- }
-
- bufp = buf + sizeof (buf) / sizeof (buf[0]);
-
- if (negative_number)
- u_number_value = - u_number_value;
-
- do
- {
- if (tz_colon_mask & 1)
- *--bufp = ':';
- tz_colon_mask >>= 1;
- *--bufp = u_number_value % 10 + L_('0');
- u_number_value /= 10;
- }
- while (u_number_value != 0 || tz_colon_mask != 0);
-
- do_number_sign_and_padding:
- if (pad == 0)
- pad = L_('0');
- if (width < 0)
- width = digits;
-
- {
- CHAR_T sign_char = (negative_number ? L_('-')
- : always_output_a_sign ? L_('+')
- : 0);
- int numlen = buf + sizeof buf / sizeof buf[0] - bufp;
- int shortage = width - !!sign_char - numlen;
- int padding = pad == L_('-') || shortage <= 0 ? 0 : shortage;
-
- if (sign_char)
- {
- if (pad == L_('_'))
- {
- if (p)
- memset_space (p, padding);
- i += padding;
- width -= padding;
- }
- width_add1 (0, sign_char);
- width--;
- }
-
- cpy (numlen, bufp);
- }
- break;
-
- case L_('F'):
- if (modifier != 0)
- goto bad_format;
- if (pad == 0 && width < 0)
- {
- pad = L_('+');
- subwidth = 4;
- }
- else
- {
- subwidth = width - 6;
- if (subwidth < 0)
- subwidth = 0;
- }
- subfmt = L_("%Y-%m-%d");
- goto subformat_width;
-
- case L_('H'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, tp->tm_hour);
-
- case L_('I'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, hour12);
-
- case L_('k'): /* GNU extension. */
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER_SPACEPAD (2, tp->tm_hour);
-
- case L_('l'): /* GNU extension. */
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER_SPACEPAD (2, hour12);
-
- case L_('j'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_SIGNED_NUMBER (3, tp->tm_yday < -1, tp->tm_yday + 1U);
-
- case L_('M'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, tp->tm_min);
-
- case L_('m'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_SIGNED_NUMBER (2, tp->tm_mon < -1, tp->tm_mon + 1U);
-
-#ifndef _LIBC
- case L_('N'): /* GNU extension. */
- if (modifier == L_('E'))
- goto bad_format;
- {
- int n = ns, ns_digits = 9;
- if (width <= 0)
- width = ns_digits;
- int ndigs = ns_digits;
- while (width < ndigs || (1 < ndigs && n % 10 == 0))
- ndigs--, n /= 10;
- for (int j = ndigs; 0 < j; j--)
- buf[j - 1] = n % 10 + L_('0'), n /= 10;
- if (!pad)
- pad = L_('0');
- width_cpy (0, ndigs, buf);
- width_add (width - ndigs, 0, (void) 0);
- }
- break;
-#endif
-
- case L_('n'):
- add1 (L_('\n'));
- break;
-
- case L_('P'):
- to_lowcase = true;
-#ifndef _NL_CURRENT
- format_char = L_('p');
-#endif
- FALLTHROUGH;
- case L_('p'):
- if (change_case)
- {
- to_uppcase = false;
- to_lowcase = true;
- }
-#ifdef _NL_CURRENT
- cpy (ap_len, ampm);
- break;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('q'): /* GNU extension. */
- DO_SIGNED_NUMBER (1, false, ((tp->tm_mon * 11) >> 5) + 1);
-
- case L_('R'):
- subfmt = L_("%H:%M");
- goto subformat;
-
- case L_('r'):
-#ifdef _NL_CURRENT
- if (*(subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME,
- NLW(T_FMT_AMPM)))
- == L_('\0'))
- subfmt = L_("%I:%M:%S %p");
- goto subformat;
-#else
- goto underlying_strftime;
-#endif
-
- case L_('S'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, tp->tm_sec);
-
- case L_('s'): /* GNU extension. */
- {
- struct tm ltm;
- time_t t;
-
- ltm = *tp;
- ltm.tm_yday = -1;
- t = mktime_z (tz, <m);
- if (ltm.tm_yday < 0)
- {
- errno = EOVERFLOW;
- return 0;
- }
-
- /* Generate string value for T using time_t arithmetic;
- this works even if sizeof (long) < sizeof (time_t). */
-
- bufp = buf + sizeof (buf) / sizeof (buf[0]);
- negative_number = t < 0;
-
- do
- {
- int d = t % 10;
- t /= 10;
- *--bufp = (negative_number ? -d : d) + L_('0');
- }
- while (t != 0);
-
- digits = 1;
- always_output_a_sign = false;
- goto do_number_sign_and_padding;
- }
-
- case L_('X'):
- if (modifier == L_('O'))
- goto bad_format;
-#ifdef _NL_CURRENT
- if (! (modifier == L_('E')
- && (*(subfmt =
- (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ERA_T_FMT)))
- != L_('\0'))))
- subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(T_FMT));
- goto subformat;
-#else
- goto underlying_strftime;
-#endif
- case L_('T'):
- subfmt = L_("%H:%M:%S");
- goto subformat;
-
- case L_('t'):
- add1 (L_('\t'));
- break;
-
- case L_('u'):
- DO_NUMBER (1, (tp->tm_wday - 1 + 7) % 7 + 1);
-
- case L_('U'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, (tp->tm_yday - tp->tm_wday + 7) / 7);
-
- case L_('V'):
- case L_('g'):
- case L_('G'):
- if (modifier == L_('E'))
- goto bad_format;
- {
- /* YEAR is a leap year if and only if (tp->tm_year + TM_YEAR_BASE)
- is a leap year, except that YEAR and YEAR - 1 both work
- correctly even when (tp->tm_year + TM_YEAR_BASE) would
- overflow. */
- int year = (tp->tm_year
- + (tp->tm_year < 0
- ? TM_YEAR_BASE % 400
- : TM_YEAR_BASE % 400 - 400));
- int year_adjust = 0;
- int days = iso_week_days (tp->tm_yday, tp->tm_wday);
-
- if (days < 0)
- {
- /* This ISO week belongs to the previous year. */
- year_adjust = -1;
- days = iso_week_days (tp->tm_yday + (365 + __isleap (year -
1)),
- tp->tm_wday);
- }
- else
- {
- int d = iso_week_days (tp->tm_yday - (365 + __isleap (year)),
- tp->tm_wday);
- if (0 <= d)
- {
- /* This ISO week belongs to the next year. */
- year_adjust = 1;
- days = d;
- }
- }
-
- switch (*f)
- {
- case L_('g'):
- {
- int yy = (tp->tm_year % 100 + year_adjust) % 100;
- DO_YEARISH (2, false,
- (0 <= yy
- ? yy
- : tp->tm_year < -TM_YEAR_BASE - year_adjust
- ? -yy
- : yy + 100));
- }
-
- case L_('G'):
- DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE - year_adjust,
- (tp->tm_year + (unsigned int) TM_YEAR_BASE
- + year_adjust));
-
- default:
- DO_NUMBER (2, days / 7 + 1);
- }
- }
-
- case L_('W'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (2, (tp->tm_yday - (tp->tm_wday - 1 + 7) % 7 + 7) / 7);
-
- case L_('w'):
- if (modifier == L_('E'))
- goto bad_format;
-
- DO_NUMBER (1, tp->tm_wday);
-
- case L_('Y'):
- if (modifier == L_('E'))
- {
-#if HAVE_STRUCT_ERA_ENTRY
- struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
- if (era)
- {
-# ifdef COMPILE_WIDE
- subfmt = era->era_wformat;
-# else
- subfmt = era->era_format;
-# endif
- if (pad == 0)
- pad = yr_spec;
- goto subformat;
- }
-#else
- goto underlying_strftime;
-#endif
- }
- if (modifier == L_('O'))
- goto bad_format;
-
- DO_YEARISH (4, tp->tm_year < -TM_YEAR_BASE,
- tp->tm_year + (unsigned int) TM_YEAR_BASE);
-
- case L_('y'):
- if (modifier == L_('E'))
- {
-#if HAVE_STRUCT_ERA_ENTRY
- struct era_entry *era = _nl_get_era_entry (tp HELPER_LOCALE_ARG);
- if (era)
- {
- int delta = tp->tm_year - era->start_date[0];
- if (pad == 0)
- pad = yr_spec;
- DO_NUMBER (2, (era->offset
- + delta * era->absolute_direction));
- }
-#else
- goto underlying_strftime;
-#endif
- }
-
- {
- int yy = tp->tm_year % 100;
- if (yy < 0)
- yy = tp->tm_year < - TM_YEAR_BASE ? -yy : yy + 100;
- DO_YEARISH (2, false, yy);
- }
-
- case L_('Z'):
- if (change_case)
- {
- to_uppcase = false;
- to_lowcase = true;
- }
-
-#ifdef COMPILE_WIDE
- {
- /* The zone string is always given in multibyte form. We have
- to convert it to wide character. */
- size_t w = pad == L_('-') || width < 0 ? 0 : width;
- char const *z = zone;
- mbstate_t st = {0};
- size_t len = __mbsrtowcs_l (p, &z, maxsize - i, &st, loc);
- if (len == (size_t) -1)
- return 0;
- size_t incr = len < w ? w : len;
- if (incr >= maxsize - i)
- {
- errno = ERANGE;
- return 0;
- }
- if (p)
- {
- if (len < w)
- {
- size_t delta = w - len;
- __wmemmove (p + delta, p, len);
- wchar_t wc = pad == L_('0') || pad == L_('+') ? L'0' : L'
';
- wmemset (p, wc, delta);
- }
- p += incr;
- }
- i += incr;
- }
-#else
- cpy (strlen (zone), zone);
-#endif
- break;
-
- case L_(':'):
- /* :, ::, and ::: are valid only just before 'z'.
- :::: etc. are rejected later. */
- for (colons = 1; f[colons] == L_(':'); colons++)
- continue;
- if (f[colons] != L_('z'))
- goto bad_format;
- f += colons;
- goto do_z_conversion;
-
- case L_('z'):
- colons = 0;
-
- do_z_conversion:
- if (tp->tm_isdst < 0)
- break;
-
- {
- int diff;
- int hour_diff;
- int min_diff;
- int sec_diff;
-#if HAVE_TM_GMTOFF
- diff = tp->tm_gmtoff;
-#else
- if (!tz)
- diff = 0;
- else
- {
- struct tm gtm;
- struct tm ltm;
- time_t lt;
-
- /* POSIX.1 requires that local time zone information be used as
- though strftime called tzset. */
-# ifndef my_strftime
- if (!*tzset_called)
- {
- tzset ();
- *tzset_called = true;
- }
-# endif
-
- ltm = *tp;
- ltm.tm_wday = -1;
- lt = mktime_z (tz, <m);
- if (ltm.tm_wday < 0 || ! localtime_rz (0, <, >m))
- break;
- diff = tm_diff (<m, >m);
- }
-#endif
-
- negative_number = diff < 0 || (diff == 0 && *zone == '-');
- hour_diff = diff / 60 / 60;
- min_diff = diff / 60 % 60;
- sec_diff = diff % 60;
-
- switch (colons)
- {
- case 0: /* +hhmm */
- DO_TZ_OFFSET (5, 0, hour_diff * 100 + min_diff);
-
- case 1: tz_hh_mm: /* +hh:mm */
- DO_TZ_OFFSET (6, 04, hour_diff * 100 + min_diff);
-
- case 2: tz_hh_mm_ss: /* +hh:mm:ss */
- DO_TZ_OFFSET (9, 024,
- hour_diff * 10000 + min_diff * 100 + sec_diff);
-
- case 3: /* +hh if possible, else +hh:mm, else +hh:mm:ss */
- if (sec_diff != 0)
- goto tz_hh_mm_ss;
- if (min_diff != 0)
- goto tz_hh_mm;
- DO_TZ_OFFSET (3, 0, hour_diff);
-
- default:
- goto bad_format;
- }
- }
-
- case L_('\0'): /* GNU extension: % at end of format. */
- bad_percent:
- --f;
- FALLTHROUGH;
- default:
- /* Unknown format; output the format, including the '%',
- since this is most likely the right thing to do if a
- multibyte string has been misparsed. */
- bad_format:
- cpy (f - percent + 1, percent);
- break;
- }
- }
-
-#if ! FPRINTFTIME
- if (p && maxsize != 0)
- *p = L_('\0');
-#endif
-
- errno = saved_errno;
- return i;
-}
+#define my_strftime nstrftime
+#include "strftime.c"
diff --git a/lib/nstrftime.c b/lib/strftime.c
similarity index 75%
copy from lib/nstrftime.c
copy to lib/strftime.c
index 69e4164dc0c..128176cad40 100644
--- a/lib/nstrftime.c
+++ b/lib/strftime.c
@@ -14,6 +14,14 @@
You should have received a copy of the GNU Lesser General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>. */
+#ifndef FPRINTFTIME
+# define FPRINTFTIME 0
+#endif
+
+#ifndef USE_C_LOCALE
+# define USE_C_LOCALE 0
+#endif
+
#ifdef _LIBC
# define USE_IN_EXTENDED_LOCALE_MODEL 1
# define HAVE_STRUCT_ERA_ENTRY 1
@@ -31,7 +39,24 @@
# include "time-internal.h"
#endif
-#include <ctype.h>
+/* Whether to require GNU behavior for AM and PM indicators, even on
+ other platforms. This matters only in non-C locales.
+ The default is to require it; you can override this via
+ AC_DEFINE([REQUIRE_GNUISH_STRFTIME_AM_PM], 1) and if you do that
+ you may be able to omit Gnulib's localename module and its dependencies. */
+#ifndef REQUIRE_GNUISH_STRFTIME_AM_PM
+# define REQUIRE_GNUISH_STRFTIME_AM_PM true
+#endif
+#if USE_C_LOCALE
+# undef REQUIRE_GNUISH_STRFTIME_AM_PM
+# define REQUIRE_GNUISH_STRFTIME_AM_PM false
+#endif
+
+#if USE_C_LOCALE
+# include "c-ctype.h"
+#else
+# include <ctype.h>
+#endif
#include <errno.h>
#include <time.h>
@@ -67,6 +92,15 @@ extern char *tzname[];
#include <stdlib.h>
#include <string.h>
+#if USE_C_LOCALE && HAVE_STRFTIME_L
+# include <locale.h>
+#endif
+
+#if (defined __NetBSD__ || defined __sun) && REQUIRE_GNUISH_STRFTIME_AM_PM
+# include <locale.h>
+# include "localename.h"
+#endif
+
#include "attribute.h"
#include <intprops.h>
@@ -121,10 +155,10 @@ extern char *tzname[];
# define mktime_z(tz, tm) mktime (tm)
# define tzname __tzname
# define tzset __tzset
-#endif
-#ifndef FPRINTFTIME
-# define FPRINTFTIME 0
+# define time_t __time64_t
+# define __gmtime_r(t, tp) __gmtime64_r (t, tp)
+# define mktime(tp) __mktime64 (tp)
#endif
#if FPRINTFTIME
@@ -266,8 +300,13 @@ extern char *tzname[];
# define TOUPPER(Ch, L) __toupper_l (Ch, L)
# define TOLOWER(Ch, L) __tolower_l (Ch, L)
# else
-# define TOUPPER(Ch, L) toupper (Ch)
-# define TOLOWER(Ch, L) tolower (Ch)
+# if USE_C_LOCALE
+# define TOUPPER(Ch, L) c_toupper (Ch)
+# define TOLOWER(Ch, L) c_tolower (Ch)
+# else
+# define TOUPPER(Ch, L) toupper (Ch)
+# define TOLOWER(Ch, L) tolower (Ch)
+# endif
# endif
#endif
/* We don't use 'isdigit' here since the locale dependent
@@ -329,6 +368,376 @@ memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, size_t
len LOCALE_PARAM)
#endif
+#if USE_C_LOCALE && HAVE_STRFTIME_L
+
+/* Cache for the C locale object.
+ Marked volatile so that different threads see the same value
+ (avoids locking). */
+static volatile locale_t c_locale_cache;
+
+/* Return the C locale object, or (locale_t) 0 with errno set
+ if it cannot be created. */
+static locale_t
+c_locale (void)
+{
+ if (!c_locale_cache)
+ c_locale_cache = newlocale (LC_ALL_MASK, "C", (locale_t) 0);
+ return c_locale_cache;
+}
+
+#endif
+
+
+#if (defined __NetBSD__ || defined __sun) && REQUIRE_GNUISH_STRFTIME_AM_PM
+
+/* Return true if an AM/PM indicator should be removed. */
+static bool
+should_remove_ampm (void)
+{
+ /* According to glibc's 'am_pm' attribute in the locale database, an AM/PM
+ indicator should be absent in the locales for the following languages:
+ ab an ast az be ber bg br bs ce cs csb cv da de dsb eo et eu fa fi fo fr
+ fur fy ga gl gv hr hsb ht hu hy it ka kk kl ku kv kw ky lb lg li lij ln
+ lt lv mg mhr mi mk mn ms mt nb nds nhn nl nn nr nso oc os pap pl pt ro
+ ru rw sah sc se sgs sk sl sm sr ss st su sv szl tg tk tn ts tt ug uk unm
+ uz ve wae wo xh zu */
+ const char *loc = gl_locale_name_unsafe (LC_TIME, "LC_TIME");
+ bool remove_ampm = false;
+ switch (loc[0])
+ {
+ case 'a':
+ switch (loc[1])
+ {
+ case 'b': case 'n': case 'z':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == 't' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'b':
+ switch (loc[1])
+ {
+ case 'e':
+ if (loc[2] == '\0' || loc[2] == '_'
+ || (loc[2] == 'r' && (loc[3] == '\0' || loc[3] == '_')))
+ remove_ampm = true;
+ break;
+ case 'g': case 'r': case 's':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'c':
+ switch (loc[1])
+ {
+ case 'e': case 'v':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == '\0' || loc[2] == '_'
+ || (loc[2] == 'b' && (loc[3] == '\0' || loc[3] == '_')))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'd':
+ switch (loc[1])
+ {
+ case 'a': case 'e':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == 'b' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'e':
+ switch (loc[1])
+ {
+ case 'o': case 't': case 'u':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'f':
+ switch (loc[1])
+ {
+ case 'a': case 'i': case 'o': case 'r': case 'y':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'u':
+ if (loc[2] == 'r' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'g':
+ switch (loc[1])
+ {
+ case 'a': case 'l': case 'v':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'h':
+ switch (loc[1])
+ {
+ case 'r': case 't': case 'u': case 'y':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == 'b' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'i':
+ switch (loc[1])
+ {
+ case 't':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'k':
+ switch (loc[1])
+ {
+ case 'a': case 'k': case 'l': case 'u': case 'v': case 'w': case 'y':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'l':
+ switch (loc[1])
+ {
+ case 'b': case 'g': case 'n': case 't': case 'v':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'i':
+ if (loc[2] == 'j' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'm':
+ switch (loc[1])
+ {
+ case 'g': case 'i': case 'k': case 'n': case 's': case 't':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'h':
+ if (loc[2] == 'r' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'n':
+ switch (loc[1])
+ {
+ case 'b': case 'l': case 'n': case 'r':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'd':
+ if (loc[2] == 's' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 'h':
+ if (loc[2] == 'n' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 's':
+ if (loc[2] == 'o' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'o':
+ switch (loc[1])
+ {
+ case 'c': case 's':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'p':
+ switch (loc[1])
+ {
+ case 'l': case 't':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'a':
+ if (loc[2] == 'p' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'r':
+ switch (loc[1])
+ {
+ case 'o': case 'u': case 'w':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 's':
+ switch (loc[1])
+ {
+ case 'c': case 'e': case 'k': case 'l': case 'm': case 'r': case 's':
+ case 't': case 'u': case 'v':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'a':
+ if (loc[2] == 'h' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 'g':
+ if (loc[2] == 's' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 'z':
+ if (loc[2] == 'l' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 't':
+ switch (loc[1])
+ {
+ case 'g': case 'k': case 'n': case 's': case 't':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'u':
+ switch (loc[1])
+ {
+ case 'g': case 'k': case 'z':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ case 'n':
+ if (loc[2] == 'm'&& (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'v':
+ switch (loc[1])
+ {
+ case 'e':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'w':
+ switch (loc[1])
+ {
+ case 'a':
+ if (loc[2] == 'e' && (loc[3] == '\0' || loc[3] == '_'))
+ remove_ampm = true;
+ break;
+ case 'o':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'x':
+ switch (loc[1])
+ {
+ case 'h':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ case 'z':
+ switch (loc[1])
+ {
+ case 'u':
+ if (loc[2] == '\0' || loc[2] == '_')
+ remove_ampm = true;
+ break;
+ default:
+ break;
+ }
+ break;
+ default:
+ break;
+ }
+ return remove_ampm;
+}
+
+#endif
+
+
#if ! HAVE_TM_GMTOFF
/* Yield the difference between *A and *B,
measured in seconds, ignoring leap seconds. */
@@ -377,15 +786,25 @@ iso_week_days (int yday, int wday)
}
+#if !defined _NL_CURRENT && (USE_C_LOCALE && !HAVE_STRFTIME_L)
+static CHAR_T const c_weekday_names[][sizeof "Wednesday"] =
+ {
+ L_("Sunday"), L_("Monday"), L_("Tuesday"), L_("Wednesday"),
+ L_("Thursday"), L_("Friday"), L_("Saturday")
+ };
+static CHAR_T const c_month_names[][sizeof "September"] =
+ {
+ L_("January"), L_("February"), L_("March"), L_("April"), L_("May"),
+ L_("June"), L_("July"), L_("August"), L_("September"), L_("October"),
+ L_("November"), L_("December")
+ };
+#endif
+
+
/* When compiling this file, GNU applications can #define my_strftime
to a symbol (typically nstrftime) to get an extended strftime with
extra arguments TZ and NS. */
-#if FPRINTFTIME
-# undef my_strftime
-# define my_strftime fprintftime
-#endif
-
#ifdef my_strftime
# define extra_args , tz, ns
# define extra_args_spec , timezone_t tz, int ns
@@ -479,6 +898,24 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
# define am_len STRLEN (a_month)
# define aam_len STRLEN (a_altmonth)
# define ap_len STRLEN (ampm)
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+/* The English abbreviated weekday names are just the first 3 characters of the
+ English full weekday names. */
+# define a_wkday \
+ (tp->tm_wday < 0 || tp->tm_wday > 6 ? L_("?") : c_weekday_names[tp->tm_wday])
+# define aw_len 3
+# define f_wkday \
+ (tp->tm_wday < 0 || tp->tm_wday > 6 ? L_("?") : c_weekday_names[tp->tm_wday])
+/* The English abbreviated month names are just the first 3 characters of the
+ English full month names. */
+# define a_month \
+ (tp->tm_mon < 0 || tp->tm_mon > 11 ? L_("?") : c_month_names[tp->tm_mon])
+# define am_len 3
+# define f_month \
+ (tp->tm_mon < 0 || tp->tm_mon > 11 ? L_("?") : c_month_names[tp->tm_mon])
+/* The English AM/PM strings happen to have the same length, namely 2. */
+# define ampm (L_("AMPM") + 2 * (tp->tm_hour > 11))
+# define ap_len 2
#endif
#if HAVE_TZNAME
char **tzname_vec = tzname;
@@ -766,7 +1203,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
to_uppcase = true;
to_lowcase = false;
}
-#ifdef _NL_CURRENT
+#if defined _NL_CURRENT || (USE_C_LOCALE && !HAVE_STRFTIME_L)
cpy (aw_len, a_wkday);
break;
#else
@@ -781,7 +1218,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
to_uppcase = true;
to_lowcase = false;
}
-#ifdef _NL_CURRENT
+#if defined _NL_CURRENT || (USE_C_LOCALE && !HAVE_STRFTIME_L)
cpy (STRLEN (f_wkday), f_wkday);
break;
#else
@@ -803,6 +1240,9 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
else
cpy (am_len, a_month);
break;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ cpy (am_len, a_month);
+ break;
#else
goto underlying_strftime;
#endif
@@ -821,6 +1261,9 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
else
cpy (STRLEN (f_month), f_month);
break;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ cpy (STRLEN (f_month), f_month);
+ break;
#else
goto underlying_strftime;
#endif
@@ -835,6 +1278,8 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
NLW(ERA_D_T_FMT)))
!= '\0')))
subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_T_FMT));
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ subfmt = L_("%a %b %e %H:%M:%S %Y");
#else
goto underlying_strftime;
#endif
@@ -855,7 +1300,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
}
break;
-#if !(defined _NL_CURRENT && HAVE_STRUCT_ERA_ENTRY)
+#if !((defined _NL_CURRENT && HAVE_STRUCT_ERA_ENTRY) || (USE_C_LOCALE &&
!HAVE_STRFTIME_L))
underlying_strftime:
{
/* The relevant information is available only via the
@@ -869,7 +1314,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
"#define strftime rpl_strftime". */
# ifdef strftime
# undef strftime
- size_t strftime ();
+ size_t strftime (char *, size_t, const char *, struct tm const *);
# endif
/* The space helps distinguish strftime failure from empty
@@ -880,9 +1325,88 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
*u++ = modifier;
*u++ = format_char;
*u = '\0';
+
+# if USE_C_LOCALE /* implies HAVE_STRFTIME_L */
+ locale_t locale = c_locale ();
+ if (!locale)
+ return 0; /* errno is set here */
+ len = strftime_l (ubuf, sizeof ubuf, ufmt, tp, locale);
+# else
len = strftime (ubuf, sizeof ubuf, ufmt, tp);
+# endif
if (len != 0)
- cpy (len - 1, ubuf + 1);
+ {
+# if defined __NetBSD__ || defined __sun /* NetBSD, Solaris */
+ if (format_char == L_('c'))
+ {
+ /* The output of the strftime %c directive consists of the
+ date, the time, and the time zone. But the time zone is
+ wrong, since neither TZ nor ZONE was passed as argument.
+ Therefore, remove the the last space-delimited word.
+ In order not to accidentally remove a date or a year
+ (that contains no letter) or an AM/PM indicator (that
has
+ length 2), remove that last word only if it contains a
+ letter and has length >= 3. */
+ char *space;
+ for (space = ubuf + len - 1; *space != ' '; space--)
+ ;
+ if (space > ubuf)
+ {
+ /* Found a space. */
+ if (strlen (space + 1) >= 3)
+ {
+ /* The last word has length >= 3. */
+ bool found_letter = false;
+ const char *p;
+ for (p = space + 1; *p != '\0'; p++)
+ if ((*p >= 'A' && *p <= 'Z')
+ || (*p >= 'a' && *p <= 'z'))
+ {
+ found_letter = true;
+ break;
+ }
+ if (found_letter)
+ {
+ /* The last word contains a letter. */
+ *space = '\0';
+ len = space - ubuf;
+ }
+ }
+ }
+ }
+# if REQUIRE_GNUISH_STRFTIME_AM_PM
+ /* The output of the strftime %p and %r directives contains
+ an AM/PM indicator even for locales where it is not
+ suitable, such as French. Remove this indicator. */
+ else if (format_char == L_('p'))
+ {
+ bool found_ampm = (len > 1);
+ if (found_ampm && should_remove_ampm ())
+ {
+ ubuf[1] = '\0';
+ len = 1;
+ }
+ }
+ else if (format_char == L_('r'))
+ {
+ char last_char = ubuf[len - 1];
+ bool found_ampm = !(last_char >= '0' && last_char <= '9');
+ if (found_ampm && should_remove_ampm ())
+ {
+ char *space;
+ for (space = ubuf + len - 1; *space != ' '; space--)
+ ;
+ if (space > ubuf)
+ {
+ *space = '\0';
+ len = space - ubuf;
+ }
+ }
+ }
+# endif
+# endif
+ cpy (len - 1, ubuf + 1);
+ }
}
break;
#endif
@@ -903,6 +1427,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
# endif
break;
}
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
#else
goto underlying_strftime;
#endif
@@ -926,6 +1451,9 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
!= L_('\0'))))
subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(D_FMT));
goto subformat;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ subfmt = L_("%m/%d/%y");
+ goto subformat;
#else
goto underlying_strftime;
#endif
@@ -1001,6 +1529,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
break;
}
}
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
#else
goto underlying_strftime;
#endif
@@ -1148,7 +1677,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
to_uppcase = false;
to_lowcase = true;
}
-#ifdef _NL_CURRENT
+#if defined _NL_CURRENT || (USE_C_LOCALE && !HAVE_STRFTIME_L)
cpy (ap_len, ampm);
break;
#else
@@ -1169,6 +1698,13 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
== L_('\0'))
subfmt = L_("%I:%M:%S %p");
goto subformat;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ subfmt = L_("%I:%M:%S %p");
+ goto subformat;
+#elif (defined __APPLE__ && defined __MACH__) || defined __FreeBSD__
+ /* macOS, FreeBSD strftime() may produce empty output for "%r". */
+ subfmt = L_("%I:%M:%S %p");
+ goto subformat;
#else
goto underlying_strftime;
#endif
@@ -1222,6 +1758,9 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
!= L_('\0'))))
subfmt = (const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(T_FMT));
goto subformat;
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
+ subfmt = L_("%H:%M:%S");
+ goto subformat;
#else
goto underlying_strftime;
#endif
@@ -1329,6 +1868,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
pad = yr_spec;
goto subformat;
}
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
#else
goto underlying_strftime;
#endif
@@ -1352,6 +1892,7 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG
(size_t maxsize)
DO_NUMBER (2, (era->offset
+ delta * era->absolute_direction));
}
+#elif USE_C_LOCALE && !HAVE_STRFTIME_L
#else
goto underlying_strftime;
#endif
diff --git a/lib/strftime.h b/lib/strftime.h
index d6efdb848a3..8ce62cdb6d7 100644
--- a/lib/strftime.h
+++ b/lib/strftime.h
@@ -21,17 +21,68 @@
extern "C" {
#endif
-/* Just like strftime, but with two more arguments:
- POSIX requires that strftime use the local timezone information.
- Use the timezone __TZ instead. Use __NS as the number of
- nanoseconds in the %N directive.
-
- On error, set errno and return 0. Otherwise, return the number of
- bytes generated (not counting the trailing NUL), preserving errno
- if the number is 0. This errno behavior is in draft POSIX 202x
- plus some requested changes to POSIX. */
-size_t nstrftime (char *restrict, size_t, char const *, struct tm const *,
- timezone_t __tz, int __ns);
+/* Formats the broken-down time *__TP, with additional __NS nanoseconds,
+ into the buffer __S of size __MAXSIZE, according to the rules of the
+ LC_TIME category of the current locale.
+
+ Uses the time zone __TZ.
+ If *__TP represents local time, __TZ should be set to
+ tzalloc (getenv ("TZ")).
+ If *__TP represents universal time (a.k.a. GMT), __TZ should be set to
+ (timezone_t) 0.
+
+ The format string __FORMAT, including GNU extensions, is described in
+ the GNU libc's strftime() documentation:
+
<https://www.gnu.org/software/libc/manual/html_node/Formatting-Calendar-Time.html>
+ Additionally, the following conversion is supported:
+ %N The number of nanoseconds, passed as __NS argument.
+ Here's a summary of the available conversions (= format directives):
+ literal characters %n %t %%
+ date:
+ century %C
+ year %Y %y
+ week-based year %G %g
+ month (in year) %m %B %b %h
+ week in year %U %W %V
+ day in year %j
+ day (in month) %d %e
+ day in week %u %w %A %a
+ year, month, day %x %F %D
+ time:
+ half-day %p %P
+ hour %H %k %I %l
+ minute (in hour) %M
+ hour, minute %R
+ second (in minute) %S
+ hour, minute, second %r %T %X
+ second (since epoch) %s
+ date and time: %c
+ time zone: %z %Z
+ nanosecond %N
+
+ Stores the result, as a string with a trailing NUL character, at the
+ beginning of the array __S[0..__MAXSIZE-1], if it fits, and returns
+ the length of that string, not counting the trailing NUL. In this case,
+ errno is preserved if the return value is 0.
+ If it does not fit, this function sets errno to ERANGE and returns 0.
+ Upon other errors, this function sets errno and returns 0 as well.
+
+ Note: The errno behavior is in draft POSIX 202x plus some requested
+ changes to POSIX.
+
+ This function is like strftime, but with two more arguments:
+ * __TZ instead of the local timezone information,
+ * __NS as the number of nanoseconds in the %N directive.
+ */
+size_t nstrftime (char *restrict __s, size_t __maxsize,
+ char const *__format,
+ struct tm const *__tp, timezone_t __tz, int __ns);
+
+/* Like nstrftime, except that it uses the "C" locale instead of the
+ current locale. */
+size_t c_nstrftime (char *restrict __s, size_t __maxsize,
+ char const *__format,
+ struct tm const *__tp, timezone_t __tz, int __ns);
#ifdef __cplusplus
}
diff --git a/lib/string.in.h b/lib/string.in.h
index 01ea3e3913b..44ec2e7ecdb 100644
--- a/lib/string.in.h
+++ b/lib/string.in.h
@@ -414,11 +414,21 @@ _GL_WARN_ON_USE (memrchr, "memrchr is unportable - "
/* Overwrite a block of memory. The compiler will not optimize
effects away, even if the block is dead after the call. */
#if @GNULIB_MEMSET_EXPLICIT@
-# if ! @HAVE_MEMSET_EXPLICIT@
+# if @REPLACE_MEMSET_EXPLICIT@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef memset_explicit
+# define memset_explicit rpl_memset_explicit
+# endif
+_GL_FUNCDECL_RPL (memset_explicit, void *,
+ (void *__dest, int __c, size_t __n) _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (memset_explicit, void *, (void *__dest, int __c, size_t
__n));
+# else
+# if !@HAVE_MEMSET_EXPLICIT@
_GL_FUNCDECL_SYS (memset_explicit, void *,
(void *__dest, int __c, size_t __n) _GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (memset_explicit, void *, (void *__dest, int __c, size_t
__n));
+# endif
_GL_CXXALIASWARN (memset_explicit);
#elif defined GNULIB_POSIXCHECK
# undef memset_explicit
diff --git a/lib/time.in.h b/lib/time.in.h
index 58e103af07c..df99c8abca9 100644
--- a/lib/time.in.h
+++ b/lib/time.in.h
@@ -154,11 +154,21 @@ _GL_WARN_ON_USE (timespec_get, "timespec_get is
unportable - "
/* Set *TS to the current time resolution, and return BASE.
Upon failure, return 0. */
# if @GNULIB_TIMESPEC_GETRES@
-# if ! @HAVE_TIMESPEC_GETRES@
+# if @REPLACE_TIMESPEC_GETRES@
+# if !(defined __cplusplus && defined GNULIB_NAMESPACE)
+# undef timespec_getres
+# define timespec_getres rpl_timespec_getres
+# endif
+_GL_FUNCDECL_RPL (timespec_getres, int, (struct timespec *ts, int base)
+ _GL_ARG_NONNULL ((1)));
+_GL_CXXALIAS_RPL (timespec_getres, int, (struct timespec *ts, int base));
+# else
+# if !@HAVE_TIMESPEC_GETRES@
_GL_FUNCDECL_SYS (timespec_getres, int, (struct timespec *ts, int base)
_GL_ARG_NONNULL ((1)));
-# endif
+# endif
_GL_CXXALIAS_SYS (timespec_getres, int, (struct timespec *ts, int base));
+# endif
_GL_CXXALIASWARN (timespec_getres);
# elif defined GNULIB_POSIXCHECK
# undef timespec_getres
@@ -428,11 +438,7 @@ _GL_CXXALIAS_SYS (ctime, char *, (time_t const *__tp));
_GL_CXXALIASWARN (ctime);
# endif
# elif defined GNULIB_POSIXCHECK
-# undef ctime
-# if HAVE_RAW_DECL_CTIME
-_GL_WARN_ON_USE (ctime, "ctime has portability problems - "
- "use gnulib module ctime for portability");
-# endif
+/* No need to warn about portability, as a more serious warning is below. */
# endif
/* Convert *TP to a date and time string. See
diff --git a/lib/time_r.c b/lib/time_r.c
index 3ef0b36802c..b724f3b38de 100644
--- a/lib/time_r.c
+++ b/lib/time_r.c
@@ -21,6 +21,11 @@
#include <time.h>
+/* The replacement functions in this file are only used on native Windows.
+ They are multithread-safe, because the gmtime() and localtime() functions
+ on native Windows — both in the ucrt and in the older MSVCRT — return a
+ pointer to a 'struct tm' in thread-local memory. */
+
static struct tm *
copy_tm_result (struct tm *dest, struct tm const *src)
{
diff --git a/lib/warn-on-use.h b/lib/warn-on-use.h
index 8f4d40dcbeb..701013a07f4 100644
--- a/lib/warn-on-use.h
+++ b/lib/warn-on-use.h
@@ -32,6 +32,10 @@
_GL_WARN_ON_USE_ATTRIBUTE is for functions with 'static' or 'inline'
linkage.
+ _GL_WARN_ON_USE should not be used more than once for a given function
+ in a given compilation unit (because this may generate a warning even
+ if the function is never called).
+
However, one of the reasons that a function is a portability trap is
if it has the wrong signature. Declaring FUNCTION with a different
signature in C is a compilation error, so this macro must use the
diff --git a/lib/xalloc-oversized.h b/lib/xalloc-oversized.h
index 0b7bb2cee85..7f30f83e769 100644
--- a/lib/xalloc-oversized.h
+++ b/lib/xalloc-oversized.h
@@ -29,8 +29,7 @@
is SIZE_MAX - 1. */
#define __xalloc_oversized(n, s) \
((s) != 0 \
- && ((size_t) (PTRDIFF_MAX < SIZE_MAX ? PTRDIFF_MAX : SIZE_MAX - 1) / (s) \
- < (n)))
+ && (PTRDIFF_MAX < SIZE_MAX ? PTRDIFF_MAX : SIZE_MAX - 1) / (s) < (n))
/* Return 1 if and only if an array of N objects, each of size S,
cannot exist reliably because its total size in bytes would exceed
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
index 2bd9faad69d..188eeb720c0 100644
--- a/lisp/abbrev.el
+++ b/lisp/abbrev.el
@@ -602,8 +602,7 @@ It is nil if the abbrev has already been unexpanded.")
"Undefine all abbrevs in abbrev table TABLE, leaving TABLE empty."
(setq abbrevs-changed t)
(let* ((sym (obarray-get table "")))
- (dotimes (i (length table))
- (aset table i 0))
+ (obarray-clear table)
;; Preserve the table's properties.
(cl-assert sym)
(let ((newsym (obarray-put table "")))
@@ -721,7 +720,7 @@ either a single abbrev table or a list of abbrev tables."
;; to treat the distinction between a single table and a list of tables.
(cond
((consp tables) tables)
- ((vectorp tables) (list tables))
+ ((obarrayp tables) (list tables))
(t
(let ((tables (if (listp local-abbrev-table)
(append local-abbrev-table
diff --git a/lisp/allout.el b/lisp/allout.el
index a7121efb14a..e3fe8d08841 100644
--- a/lisp/allout.el
+++ b/lisp/allout.el
@@ -161,9 +161,9 @@ respective `allout-mode' keybinding variables,
`allout-command-prefix',
(defcustom allout-command-prefix "\C-c "
"Key sequence to be used as prefix for outline mode command key bindings.
-Default is `\C-c<space>'; just `\C-c' is more short-and-sweet, if you're
-willing to let allout use a bunch of \C-c keybindings."
- :type 'string
+Default is \\`C-c SPC'; just \\`C-c' is more short-and-sweet, if you're
+willing to let allout use a bunch of \\`C-c' keybindings."
+ :type 'key-sequence
:group 'allout-keybindings
:set #'allout-compose-and-institute-keymap)
;;;_ = allout-keybindings-binding
diff --git a/lisp/auth-source.el b/lisp/auth-source.el
index 1f233f9f60f..5f5629d9cfc 100644
--- a/lisp/auth-source.el
+++ b/lisp/auth-source.el
@@ -1985,7 +1985,7 @@ entries for git.gnus.org:
(defun auth-source--decode-octal-string (string)
- "Convert octal STRING to utf-8 string. E.g: \"a\134b\" to \"a\b\"."
+ "Convert octal STRING to utf-8 string. E.g.: \"a\\134b\" to \"a\\b\"."
(let ((list (string-to-list string))
(size (length string)))
(decode-coding-string
diff --git a/lisp/bind-key.el b/lisp/bind-key.el
index 94a39f795cd..378ad69b2bc 100644
--- a/lisp/bind-key.el
+++ b/lisp/bind-key.el
@@ -155,6 +155,7 @@ add keys to that keymap."
(add-to-list 'emulation-mode-map-alists
`((override-global-mode . ,override-global-map)))
+;;;###autoload
(defvar personal-keybindings nil
"List of bindings performed by `bind-key'.
diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index 5796544c534..e13c3b56b4e 100644
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
@@ -100,6 +100,10 @@ as it is by default."
This is set by the prefix argument to `buffer-menu' and related
commands.")
+(defvar-local Buffer-menu-show-internal nil
+ "Non-nil if the current Buffer Menu lists internal buffers.
+Internal buffers are those whose names start with a space.")
+
(defvar-local Buffer-menu-filter-predicate nil
"Function to filter out buffers in the buffer list.
Buffers that don't satisfy the predicate will be skipped.
@@ -140,6 +144,7 @@ then the buffer will be displayed in the buffer list.")
"V" #'Buffer-menu-view
"O" #'Buffer-menu-view-other-window
"T" #'Buffer-menu-toggle-files-only
+ "I" #'Buffer-menu-toggle-internal
"M-s a C-s" #'Buffer-menu-isearch-buffers
"M-s a C-M-s" #'Buffer-menu-isearch-buffers-regexp
"M-s a C-o" #'Buffer-menu-multi-occur
@@ -197,6 +202,10 @@ then the buffer will be displayed in the buffer list.")
:help "Toggle whether the current buffer-menu displays only file buffers"
:style toggle
:selected Buffer-menu-files-only]
+ ["Show Internal Buffers" Buffer-menu-toggle-internal
+ :help "Toggle whether the current buffer-menu displays internal buffers"
+ :style toggle
+ :selected Buffer-menu-show-internal]
"---"
["Refresh" revert-buffer
:help "Refresh the *Buffer List* buffer contents"]
@@ -317,6 +326,11 @@ ARG, show only buffers that are visiting files."
(interactive "P")
(display-buffer (list-buffers-noselect arg)))
+(defun Buffer-menu--selection-message ()
+ (message (cond (Buffer-menu-files-only "Showing only file-visiting buffers.")
+ (Buffer-menu-show-internal "Showing all buffers.")
+ (t "Showing all buffers except internal ones."))))
+
(defun Buffer-menu-toggle-files-only (arg)
"Toggle whether the current `buffer-menu' displays only file buffers.
With a positive ARG, display only file buffers. With zero or
@@ -325,9 +339,18 @@ negative ARG, display other buffers as well."
(setq Buffer-menu-files-only
(cond ((not arg) (not Buffer-menu-files-only))
((> (prefix-numeric-value arg) 0) t)))
- (message (if Buffer-menu-files-only
- "Showing only file-visiting buffers."
- "Showing all non-internal buffers."))
+ (Buffer-menu--selection-message)
+ (revert-buffer))
+
+(defun Buffer-menu-toggle-internal (arg)
+ "Toggle whether the current `buffer-menu' displays internal buffers.
+With a positive ARG, don't show internal buffers. With zero or
+negative ARG, display internal buffers as well."
+ (interactive "P" Buffer-menu-mode)
+ (setq Buffer-menu-show-internal
+ (cond ((not arg) (not Buffer-menu-show-internal))
+ ((> (prefix-numeric-value arg) 0) t)))
+ (Buffer-menu--selection-message)
(revert-buffer))
(define-obsolete-function-alias 'Buffer-menu-sort 'tabulated-list-sort
@@ -569,13 +592,17 @@ If UNMARK is non-nil, unmark them."
(defun Buffer-menu-other-window ()
"Select this line's buffer in other window, leaving buffer menu visible."
(interactive nil Buffer-menu-mode)
- (switch-to-buffer-other-window (Buffer-menu-buffer t)))
+ (let ((display-buffer-overriding-action
+ '(nil (inhibit-same-window . t))))
+ (switch-to-buffer-other-window (Buffer-menu-buffer t))))
(defun Buffer-menu-switch-other-window ()
"Make the other window select this line's buffer.
The current window remains selected."
(interactive nil Buffer-menu-mode)
- (display-buffer (Buffer-menu-buffer t) t))
+ (let ((display-buffer-overriding-action
+ '(nil (inhibit-same-window . t))))
+ (display-buffer (Buffer-menu-buffer t) t)))
(defun Buffer-menu-2-window ()
"Select this line's buffer, with previous buffer in second window."
@@ -667,6 +694,7 @@ See more at `Buffer-menu-filter-predicate'."
(marked-buffers (Buffer-menu-marked-buffers))
(buffer-menu-buffer (current-buffer))
(show-non-file (not Buffer-menu-files-only))
+ (show-internal Buffer-menu-show-internal)
(filter-predicate (and (functionp Buffer-menu-filter-predicate)
Buffer-menu-filter-predicate))
entries name-width)
@@ -686,7 +714,8 @@ See more at `Buffer-menu-filter-predicate'."
(file buffer-file-name))
(when (and (buffer-live-p buffer)
(or buffer-list
- (and (or (not (string= (substring name 0 1) " "))
+ (and (or show-internal
+ (not (string= (substring name 0 1) " "))
file)
(not (eq buffer buffer-menu-buffer))
(or file show-non-file)
diff --git a/lisp/cedet/mode-local.el b/lisp/cedet/mode-local.el
index 28f14232704..9f11b9707bd 100644
--- a/lisp/cedet/mode-local.el
+++ b/lisp/cedet/mode-local.el
@@ -1,6 +1,6 @@
;;; mode-local.el --- Support for mode local facilities -*- lexical-binding:t
-*-
;;
-;; Copyright (C) 2004-2005, 2007-2024 Free Software Foundation, Inc.
+;; Copyright (C) 2004-2024 Free Software Foundation, Inc.
;;
;; Author: David Ponce <david@dponce.com>
;; Created: 27 Apr 2004
@@ -84,7 +84,7 @@ MODES can be a symbol or a list of symbols.
FUNCTION does not have arguments."
(setq modes (ensure-list modes))
(mode-local-map-file-buffers
- function (lambda () (apply #'derived-mode-p modes))))
+ function (lambda () (derived-mode-p modes))))
;;; Hook machinery
;;
diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el
index a4be5bf67e2..f63d316c1ac 100644
--- a/lisp/cedet/semantic/lex-spp.el
+++ b/lisp/cedet/semantic/lex-spp.el
@@ -153,13 +153,13 @@ The search priority is:
"Return the dynamic macro map for the current buffer."
(or semantic-lex-spp-dynamic-macro-symbol-obarray
(setq semantic-lex-spp-dynamic-macro-symbol-obarray
- (make-vector 13 0))))
+ (obarray-make 13))))
(defsubst semantic-lex-spp-dynamic-map-stack ()
"Return the dynamic macro map for the current buffer."
(or semantic-lex-spp-dynamic-macro-symbol-obarray-stack
(setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack
- (make-vector 13 0))))
+ (obarray-make 13))))
(defun semantic-lex-spp-value-valid-p (value)
"Return non-nil if VALUE is valid."
@@ -260,7 +260,7 @@ NAME is the name of the spp macro symbol to define.
REPLACEMENT a string that would be substituted in for NAME."
;; Create the symbol hash table
- (let ((semantic-lex-spp-macro-symbol-obarray (make-vector 13 0))
+ (let ((semantic-lex-spp-macro-symbol-obarray (obarray-make 13))
spec)
;; fill it with stuff
(while specs
diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el
index b32cb96bed9..f3d671ac312 100644
--- a/lisp/cedet/semantic/lex.el
+++ b/lisp/cedet/semantic/lex.el
@@ -259,7 +259,7 @@ If optional argument PROPSPECS is non-nil, then interpret
it, and
apply those properties.
PROPSPECS must be a list of (NAME PROPERTY VALUE) elements."
;; Create the symbol hash table
- (let ((semantic-flex-keywords-obarray (make-vector 13 0))
+ (let ((semantic-flex-keywords-obarray (obarray-make 13))
spec)
;; fill it with stuff
(while specs
@@ -416,7 +416,7 @@ If optional argument PROPSPECS is non-nil, then interpret
it, and
apply those properties.
PROPSPECS must be a list of (TYPE PROPERTY VALUE)."
;; Create the symbol hash table
- (let* ((semantic-lex-types-obarray (make-vector 13 0))
+ (let* ((semantic-lex-types-obarray (obarray-make 13))
spec type tokens token alist default)
;; fill it with stuff
(while specs
diff --git a/lisp/comint.el b/lisp/comint.el
index 0a9cdb44bef..655ff30469c 100644
--- a/lisp/comint.el
+++ b/lisp/comint.el
@@ -254,7 +254,7 @@ This variable is buffer-local."
See also `comint-read-input-ring' and `comint-write-input-ring'.
`comint-mode' makes this a buffer-local variable. You probably want
to set this in a mode hook, rather than customize the default value."
- :type '(choice (const :tag "nil" nil)
+ :type '(choice (const :tag "Disable input history" nil)
file)
:group 'comint)
diff --git a/lisp/completion-preview.el b/lisp/completion-preview.el
index 6fd60f3c416..e827da43a08 100644
--- a/lisp/completion-preview.el
+++ b/lisp/completion-preview.el
@@ -302,21 +302,21 @@ point, otherwise hide it."
;; never display a stale preview and that the preview doesn't
;; flicker, even with slow completion backends.
(let* ((beg (completion-preview--get 'completion-preview-beg))
+ (end (max (point) (overlay-start completion-preview--overlay)))
(cands (completion-preview--get 'completion-preview-cands))
(index (completion-preview--get 'completion-preview-index))
(cand (nth index cands))
- (len (length cand))
- (end (+ beg len))
- (cur (point))
- (face (get-text-property 0 'face (completion-preview--get
'after-string))))
- (if (and (< beg cur end) (string-prefix-p (buffer-substring beg cur)
cand))
+ (after (completion-preview--get 'after-string))
+ (face (get-text-property 0 'face after)))
+ (if (and (<= beg (point) end (1- (+ beg (length cand))))
+ (string-prefix-p (buffer-substring beg end) cand))
;; The previous preview is still applicable, update it.
(overlay-put (completion-preview--make-overlay
- cur (propertize (substring cand (- cur beg))
+ end (propertize (substring cand (- end beg))
'face face
'mouse-face
'completion-preview-highlight
'keymap completion-preview--mouse-map))
- 'completion-preview-end cur)
+ 'completion-preview-end end)
;; The previous preview is no longer applicable, hide it.
(completion-preview-active-mode -1))))
;; Run `completion-at-point-functions' to get a new candidate.
@@ -366,16 +366,16 @@ prefix argument and defaults to 1."
(interactive "p")
(when completion-preview-active-mode
(let* ((beg (completion-preview--get 'completion-preview-beg))
+ (end (completion-preview--get 'completion-preview-end))
(all (completion-preview--get 'completion-preview-cands))
(cur (completion-preview--get 'completion-preview-index))
(len (length all))
(new (mod (+ cur direction) len))
- (str (nth new all))
- (pos (point)))
- (while (or (<= (+ beg (length str)) pos)
- (not (string-prefix-p (buffer-substring beg pos) str)))
+ (str (nth new all)))
+ (while (or (<= (+ beg (length str)) end)
+ (not (string-prefix-p (buffer-substring beg end) str)))
(setq new (mod (+ new direction) len) str (nth new all)))
- (let ((aft (propertize (substring str (- pos beg))
+ (let ((aft (propertize (substring str (- end beg))
'face (if (< 1 len)
'completion-preview
'completion-preview-exact)
diff --git a/lisp/completion.el b/lisp/completion.el
index ab7f2a7bc52..6c758e56eab 100644
--- a/lisp/completion.el
+++ b/lisp/completion.el
@@ -875,11 +875,11 @@ This is sensitive to `case-fold-search'."
;; GNU implements obarrays
(defconst cmpl-obarray-length 511)
-(defvar cmpl-prefix-obarray (make-vector cmpl-obarray-length 0)
+(defvar cmpl-prefix-obarray (obarray-make cmpl-obarray-length)
"An obarray used to store the downcased completion prefixes.
Each symbol is bound to a list of completion entries.")
-(defvar cmpl-obarray (make-vector cmpl-obarray-length 0)
+(defvar cmpl-obarray (obarray-make cmpl-obarray-length)
"An obarray used to store the downcased completions.
Each symbol is bound to a single completion entry.")
@@ -962,8 +962,8 @@ Each symbol is bound to a single completion entry.")
(defun clear-all-completions ()
"Initialize the completion storage. All existing completions are lost."
(interactive)
- (setq cmpl-prefix-obarray (make-vector cmpl-obarray-length 0))
- (setq cmpl-obarray (make-vector cmpl-obarray-length 0)))
+ (setq cmpl-prefix-obarray (obarray-make cmpl-obarray-length))
+ (setq cmpl-obarray (obarray-make cmpl-obarray-length)))
(defun list-all-completions ()
"Return a list of all the known completion entries."
diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el
index 38b6ec984ab..8fad51dc116 100644
--- a/lisp/cus-edit.el
+++ b/lisp/cus-edit.el
@@ -1227,6 +1227,41 @@ If OTHER-WINDOW is non-nil, display in another window."
(unless (eq symbol basevar)
(message "`%s' is an alias for `%s'" symbol basevar))))
+;;;###autoload
+(defun customize-toggle-option (symbol)
+ "Toggle the value of boolean option SYMBOL for this session."
+ (interactive (let ((prompt "Toggle boolean option: ") opts)
+ (mapatoms
+ (lambda (sym)
+ (when (eq (get sym 'custom-type) 'boolean)
+ (push sym opts))))
+ (list (intern (completing-read prompt opts nil nil nil nil
+ (symbol-at-point))))))
+ (let* ((setter (or (get symbol 'custom-set) #'set-default))
+ (getter (or (get symbol 'custom-get) #'symbol-value))
+ (value (condition-case nil
+ (funcall getter symbol)
+ (void-variable (error "`%s' is not bound" symbol))))
+ (type (get symbol 'custom-type)))
+ (cond
+ ((eq type 'boolean))
+ ((and (null type)
+ (yes-or-no-p
+ (format "`%s' doesn't have a type, and has the value %S. \
+Proceed to toggle?" symbol value))))
+ ((yes-or-no-p
+ (format "`%s' is of type %s, and has the value %S. \
+Proceed to toggle?"
+ symbol type value)))
+ ((error "Abort toggling of option `%s'" symbol)))
+ (message "%s user options `%s'."
+ (if (funcall setter symbol (not value))
+ "Enabled" "Disabled")
+ symbol)))
+
+;;;###autoload
+(defalias 'toggle-option #'customize-toggle-option)
+
;;;###autoload
(defalias 'customize-variable-other-window 'customize-option-other-window)
diff --git a/lisp/cus-face.el b/lisp/cus-face.el
index 0c8b6b0b97c..47afa841f5e 100644
--- a/lisp/cus-face.el
+++ b/lisp/cus-face.el
@@ -32,7 +32,7 @@
(defun custom-declare-face (face spec doc &rest args)
"Like `defface', but with FACE evaluated as a normal argument."
(when (and doc
- (not (stringp doc)))
+ (not (documentation-stringp doc)))
(error "Invalid (or missing) doc string %S" doc))
(unless (get face 'face-defface-spec)
(face-spec-set face (purecopy spec) 'face-defface-spec)
diff --git a/lisp/cus-start.el b/lisp/cus-start.el
index 7e0b64e9067..3fe62c8d0da 100644
--- a/lisp/cus-start.el
+++ b/lisp/cus-start.el
@@ -371,6 +371,7 @@ Leaving \"Default\" unchecked is equivalent with specifying
a default of
(auto-save-timeout auto-save (choice (const :tag "off" nil)
(integer :format "%v")))
(echo-keystrokes minibuffer number)
+ (echo-keystrokes-help minibuffer boolean "30.1")
(polling-period keyboard float)
(double-click-time mouse (restricted-sexp
:match-alternatives (integerp 'nil 't)))
diff --git a/lisp/desktop.el b/lisp/desktop.el
index e3994ceb83c..3fa09ce6a41 100644
--- a/lisp/desktop.el
+++ b/lisp/desktop.el
@@ -163,10 +163,19 @@ Used at desktop read to provide backward compatibility.")
(define-minor-mode desktop-save-mode
"Toggle desktop saving (Desktop Save mode).
-When Desktop Save mode is enabled, the state of Emacs is saved from
-one session to another. In particular, Emacs will save the desktop when
-it exits (this may prompt you; see the option `desktop-save'). The next
-time Emacs starts, if this mode is active it will restore the desktop.
+When Desktop Save mode is enabled, the state of Emacs is saved from one
+session to another. The saved Emacs \"desktop configuration\" includes the
+buffers, their file names, major modes, buffer positions, window and frame
+configuration, and some important global variables.
+
+To enable this feature for future sessions, customize `desktop-save-mode'
+to t, or add this line in your init file:
+
+ (desktop-save-mode 1)
+
+When this mode is enabled, Emacs will save the desktop when it exits
+(this may prompt you, see the option `desktop-save'). The next time
+Emacs starts, if this mode is active it will restore the desktop.
To manually save the desktop at any time, use the command \\[desktop-save].
To load it, use \\[desktop-read].
diff --git a/lisp/dired.el b/lisp/dired.el
index cef93ab757c..9e3b888df14 100644
--- a/lisp/dired.el
+++ b/lisp/dired.el
@@ -4321,6 +4321,11 @@ this subdir."
(prefix-numeric-value arg)
(lambda ()
(when (or (not (looking-at-p dired-re-dot))
+ ;; Don't skip symlinks to ".", "..", etc.
+ (save-excursion
+ (re-search-forward
+ dired-permission-flags-regexp nil t)
+ (eq (char-after (match-beginning 1)) ?l))
(not (equal dired-marker-char dired-del-marker)))
(delete-char 1)
(insert dired-marker-char))))))))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index ea9298c6646..c3355eedd75 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -231,17 +231,8 @@ This includes variable references and calls to functions
such as `car'."
:type 'boolean)
(defvar byte-compile-dynamic nil
- "If non-nil, compile function bodies so they load lazily.
-They are hidden in comments in the compiled file,
-and each one is brought into core when the
-function is called.
-
-To enable this option, make it a file-local variable
-in the source file you want it to apply to.
-For example, add -*-byte-compile-dynamic: t;-*- on the first line.
-
-When this option is true, if you load the compiled file and then move it,
-the functions you loaded will not be able to run.")
+ "Formerly used to compile function bodies so they load lazily.
+This variable no longer has any effect.")
(make-obsolete-variable 'byte-compile-dynamic "not worthwhile any more."
"27.1")
;;;###autoload(put 'byte-compile-dynamic 'safe-local-variable 'booleanp)
@@ -294,6 +285,7 @@ The information is logged to `byte-compile-log-buffer'."
(defconst byte-compile-warning-types
'( callargs constants
docstrings docstrings-non-ascii-quotes docstrings-wide
+ docstrings-control-chars
empty-body free-vars ignored-return-value interactive-only
lexical lexical-dynamic make-local
mapcar ; obsolete
@@ -316,6 +308,8 @@ Elements of the list may be:
docstrings that are too wide, containing lines longer than both
`byte-compile-docstring-max-column' and `fill-column' characters.
Only enabled when `docstrings' also is.
+ docstrings-control-chars
+ docstrings that contain control characters other than NL and TAB
empty-body body argument to a special form or macro is empty.
free-vars references to variables not in the current lexical scope.
ignored-return-value
@@ -354,7 +348,7 @@ A value of `all' really means all."
'(docstrings-non-ascii-quotes)
"List of warning types that are only enabled during Emacs builds.
This is typically either warning types that are being phased in
-(but shouldn't be enabled for packages yet), or that are only relevant
+\(but shouldn't be enabled for packages yet), or that are only relevant
for the Emacs build itself.")
(defvar byte-compile--suppressed-warnings nil
@@ -1749,68 +1743,100 @@ Also ignore URLs."
The byte-compiler will emit a warning for documentation strings
containing lines wider than this. If `fill-column' has a larger
value, it will override this variable."
- :group 'bytecomp
:type 'natnum
:safe #'natnump
:version "28.1")
-(define-obsolete-function-alias 'byte-compile-docstring-length-warn
- 'byte-compile-docstring-style-warn "29.1")
-
-(defun byte-compile-docstring-style-warn (form)
- "Warn if there are stylistic problems with the docstring in FORM.
-Warn if documentation string of FORM is too wide.
+(defun byte-compile--list-with-n (list n elem)
+ "Return LIST with its Nth element replaced by ELEM."
+ (if (eq elem (nth n list))
+ list
+ (nconc (take n list)
+ (list elem)
+ (nthcdr (1+ n) list))))
+
+(defun byte-compile--docstring-style-warn (docs kind name)
+ "Warn if there are stylistic problems in the docstring DOCS.
+Warn if documentation string is too wide.
It is too wide if it has any lines longer than the largest of
`fill-column' and `byte-compile-docstring-max-column'."
(when (byte-compile-warning-enabled-p 'docstrings)
- (let* ((kind nil) (name nil) (docs nil)
+ (let* ((name (if (eq (car-safe name) 'quote) (cadr name) name))
(prefix (lambda ()
(format "%s%s"
kind
- (if name (format-message " `%s' " name) "")))))
- (pcase (car form)
- ((or 'autoload 'custom-declare-variable 'defalias
- 'defconst 'define-abbrev-table
- 'defvar 'defvaralias
- 'custom-declare-face)
- (setq kind (nth 0 form))
- (setq name (nth 1 form))
- (when (and (consp name) (eq (car name) 'quote))
- (setq name (cadr name)))
- (setq docs (nth 3 form)))
- ('lambda
- (setq kind "") ; can't be "function", unfortunately
- (setq docs (nth 2 form))))
- (when (and kind docs (stringp docs))
- (let ((col (max byte-compile-docstring-max-column fill-column)))
- (when (and (byte-compile-warning-enabled-p 'docstrings-wide)
- (byte-compile--wide-docstring-p docs col))
- (byte-compile-warn-x
- name
- "%sdocstring wider than %s characters" (funcall prefix) col)))
- ;; There's a "naked" ' character before a symbol/list, so it
- ;; should probably be quoted with \=.
- (when (string-match-p (rx (| (in " \t") bol)
- (? (in "\"#"))
- "'"
- (in "A-Za-z" "("))
+ (if name (format-message " `%S' " name) "")))))
+ (let ((col (max byte-compile-docstring-max-column fill-column)))
+ (when (and (byte-compile-warning-enabled-p 'docstrings-wide)
+ (byte-compile--wide-docstring-p docs col))
+ (byte-compile-warn-x
+ name
+ "%sdocstring wider than %s characters" (funcall prefix) col)))
+
+ (when (byte-compile-warning-enabled-p 'docstrings-control-chars)
+ (let ((start 0)
+ (len (length docs)))
+ (while (and (< start len)
+ (string-match (rx (intersection (in (0 . 31) 127)
+ (not (in "\n\t"))))
+ docs start))
+ (let* ((ofs (match-beginning 0))
+ (c (aref docs ofs)))
+ ;; FIXME: it should be possible to use the exact source position
+ ;; of the control char in most cases, and it would be helpful
+ (byte-compile-warn-x
+ name
+ "%sdocstring contains control char #x%02x (position %d)"
+ (funcall prefix) c ofs)
+ (setq start (1+ ofs))))))
+
+ ;; There's a "naked" ' character before a symbol/list, so it
+ ;; should probably be quoted with \=.
+ (when (string-match-p (rx (| (in " \t") bol)
+ (? (in "\"#"))
+ "'"
+ (in "A-Za-z" "("))
+ docs)
+ (byte-compile-warn-x
+ name
+ (concat "%sdocstring has wrong usage of unescaped single quotes"
+ " (use \\=%c or different quoting such as %c...%c)")
+ (funcall prefix) ?' ?` ?'))
+ ;; There's a "Unicode quote" in the string -- it should probably
+ ;; be an ASCII one instead.
+ (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes)
+ (when (string-match-p (rx (| " \"" (in " \t") bol)
+ (in "‘’"))
docs)
(byte-compile-warn-x
name
- (concat "%sdocstring has wrong usage of unescaped single quotes"
- " (use \\=%c or different quoting such as %c...%c)")
- (funcall prefix) ?' ?` ?'))
- ;; There's a "Unicode quote" in the string -- it should probably
- ;; be an ASCII one instead.
- (when (byte-compile-warning-enabled-p 'docstrings-non-ascii-quotes)
- (when (string-match-p (rx (| " \"" (in " \t") bol)
- (in "‘’"))
- docs)
- (byte-compile-warn-x
- name
- "%sdocstring uses curved single quotes; use %s instead of ‘...’"
- (funcall prefix) "`...'"))))))
- form)
+ "%sdocstring uses curved single quotes; use %s instead of ‘...’"
+ (funcall prefix) "`...'"))))))
+
+(defvar byte-compile--\#$) ; Special value that will print as `#$'.
+(defvar byte-compile--docstrings nil "Table of already compiled docstrings.")
+
+(defun byte-compile--docstring (doc kind name &optional is-a-value)
+ (byte-compile--docstring-style-warn doc kind name)
+ ;; Make docstrings dynamic, when applicable.
+ (cond
+ ((and byte-compile-dynamic-docstrings
+ ;; The native compiler doesn't use those dynamic docstrings.
+ (not byte-native-compiling)
+ ;; Docstrings can only be dynamic when compiling a file.
+ byte-compile--\#$)
+ (let* ((byte-pos (with-memoization
+ ;; Reuse a previously written identical docstring.
+ ;; This is not done out of thriftiness but to try and
+ ;; make sure that "equal" functions remain `equal'.
+ ;; (Often those identical docstrings come from
+ ;; `help-add-fundoc-usage').
+ ;; Needed e.g. for `advice-tests-nadvice'.
+ (gethash doc byte-compile--docstrings)
+ (byte-compile-output-as-comment doc nil)))
+ (newdoc (cons byte-compile--\#$ byte-pos)))
+ (if is-a-value newdoc (macroexp-quote newdoc))))
+ (t doc)))
;; If we have compiled any calls to functions which are not known to be
;; defined, issue a warning enumerating them.
@@ -1845,6 +1871,8 @@ It is too wide if it has any lines longer than the
largest of
;; macroenvironment.
(copy-alist byte-compile-initial-macro-environment))
(byte-compile--outbuffer nil)
+ (byte-compile--\#$ nil)
+ (byte-compile--docstrings (make-hash-table :test 'equal))
(overriding-plist-environment nil)
(byte-compile-function-environment nil)
(byte-compile-bound-variables nil)
@@ -1858,7 +1886,6 @@ It is too wide if it has any lines longer than the
largest of
;;
(byte-compile-verbose byte-compile-verbose)
(byte-optimize byte-optimize)
- (byte-compile-dynamic byte-compile-dynamic)
(byte-compile-dynamic-docstrings
byte-compile-dynamic-docstrings)
(byte-compile-warnings byte-compile-warnings)
@@ -2373,7 +2400,12 @@ With argument ARG, insert value in current buffer after
the form."
(setq case-fold-search nil))
(displaying-byte-compile-warnings
(with-current-buffer inbuffer
- (when byte-compile-current-file
+ (when byte-compile-dest-file
+ (setq byte-compile--\#$
+ (copy-sequence ;It needs to be a fresh new object.
+ ;; Also it stands for the `load-file-name' when the `.elc'
will
+ ;; be loaded, so make it look like it.
+ byte-compile-dest-file))
(byte-compile-insert-header byte-compile-current-file
byte-compile--outbuffer)
;; Instruct native-comp to ignore this file.
@@ -2428,8 +2460,7 @@ With argument ARG, insert value in current buffer after
the form."
(defun byte-compile-insert-header (_filename outbuffer)
"Insert a header at the start of OUTBUFFER.
Call from the source buffer."
- (let ((dynamic byte-compile-dynamic)
- (optimize byte-optimize))
+ (let ((optimize byte-optimize))
(with-current-buffer outbuffer
(goto-char (point-min))
;; The magic number of .elc files is ";ELC", or 0x3B454C43. After
@@ -2463,18 +2494,11 @@ Call from the source buffer."
((eq optimize 'byte) " byte-level optimization only")
(optimize " all optimizations")
(t "out optimization"))
- ".\n"
- (if dynamic ";;; Function definitions are lazy-loaded.\n"
- "")
- "\n\n"))))
+ ".\n\n\n"))))
(defun byte-compile-output-file-form (form)
;; Write the given form to the output buffer, being careful of docstrings
- ;; (for `byte-compile-dynamic-docstrings') in defvar, defvaralias,
- ;; defconst, autoload, and custom-declare-variable.
- ;; defalias calls are output directly by byte-compile-file-form-defmumble;
- ;; it does not pay to first build the defalias in defmumble and then parse
- ;; it here.
+ ;; (for `byte-compile-dynamic-docstrings').
(when byte-native-compiling
;; Spill output for the native compiler here
(push (make-byte-to-native-top-level :form form :lexical lexical-binding)
@@ -2484,153 +2508,17 @@ Call from the source buffer."
(print-level nil)
(print-quoted t)
(print-gensym t)
- (print-circle t)) ; Handle circular data structures.
- (if (memq (car-safe form) '(defvar defvaralias defconst
- autoload custom-declare-variable))
- (byte-compile-output-docform nil nil nil '("\n(" ")") form nil 3 nil
- (memq (car form)
- '(defvaralias autoload
- custom-declare-variable)))
- (princ "\n" byte-compile--outbuffer)
- (prin1 form byte-compile--outbuffer)
- nil)))
+ (print-circle t)
+ (print-continuous-numbering t)
+ (print-number-table (make-hash-table :test #'eq)))
+ (when byte-compile--\#$
+ (puthash byte-compile--\#$ "#$" print-number-table))
+ (princ "\n" byte-compile--outbuffer)
+ (prin1 form byte-compile--outbuffer)
+ nil))
(defvar byte-compile--for-effect)
-(defun byte-compile--output-docform-recurse
- (info position form cvecindex docindex specindex quoted)
- "Print a form with a doc string. INFO is (prefix postfix).
-POSITION is where the next doc string is to be inserted.
-CVECINDEX is the index in the FORM of the constant vector, or nil.
-DOCINDEX is the index of the doc string (or nil) in the FORM.
-If SPECINDEX is non-nil, it is the index in FORM
-of the function bytecode string. In that case,
-we output that argument and the following argument
-\(the constants vector) together, for lazy loading.
-QUOTED says that we have to put a quote before the
-list that represents a doc string reference.
-`defvaralias', `autoload' and `custom-declare-variable' need that.
-
-Return the position after any inserted docstrings as comments."
- (let ((index 0)
- doc-string-position)
- ;; Insert the doc string, and make it a comment with #@LENGTH.
- (when (and byte-compile-dynamic-docstrings
- (stringp (nth docindex form)))
- (goto-char position)
- (setq doc-string-position
- (byte-compile-output-as-comment
- (nth docindex form) nil)
- position (point))
- (goto-char (point-max)))
-
- (insert (car info))
- (prin1 (car form) byte-compile--outbuffer)
- (while (setq form (cdr form))
- (setq index (1+ index))
- (insert " ")
- (cond ((and (numberp specindex) (= index specindex)
- ;; Don't handle the definition dynamically
- ;; if it refers (or might refer)
- ;; to objects already output
- ;; (for instance, gensyms in the arg list).
- (let (non-nil)
- (when (hash-table-p print-number-table)
- (maphash (lambda (_k v) (if v (setq non-nil t)))
- print-number-table))
- (not non-nil)))
- ;; Output the byte code and constants specially
- ;; for lazy dynamic loading.
- (goto-char position)
- (let ((lazy-position (byte-compile-output-as-comment
- (cons (car form) (nth 1 form))
- t)))
- (setq position (point))
- (goto-char (point-max))
- (princ (format "(#$ . %d) nil" lazy-position)
- byte-compile--outbuffer)
- (setq form (cdr form))
- (setq index (1+ index))))
- ((eq index cvecindex)
- (let* ((cvec (car form))
- (len (length cvec))
- (index2 0)
- elt)
- (insert "[")
- (while (< index2 len)
- (setq elt (aref cvec index2))
- (if (byte-code-function-p elt)
- (setq position
- (byte-compile--output-docform-recurse
- '("#[" "]") position
- (append elt nil) ; Convert the vector to a list.
- 2 4 specindex nil))
- (prin1 elt byte-compile--outbuffer))
- (setq index2 (1+ index2))
- (unless (eq index2 len)
- (insert " ")))
- (insert "]")))
- ((= index docindex)
- (cond
- (doc-string-position
- (princ (format (if quoted "'(#$ . %d)" "(#$ . %d)")
- doc-string-position)
- byte-compile--outbuffer))
- ((stringp (car form))
- (let ((print-escape-newlines nil))
- (goto-char (prog1 (1+ (point))
- (prin1 (car form)
- byte-compile--outbuffer)))
- (insert "\\\n")
- (goto-char (point-max))))
- (t (prin1 (car form) byte-compile--outbuffer))))
- (t (prin1 (car form) byte-compile--outbuffer))))
- (insert (cadr info))
- position))
-
-(defun byte-compile-output-docform (preface tailpiece name info form
- cvecindex docindex
- specindex quoted)
- "Print a form with a doc string. INFO is (prefix postfix).
-If PREFACE, NAME, and TAILPIECE are non-nil, print them too,
-before/after INFO and the FORM but after the doc string itself.
-CVECINDEX is the index in the FORM of the constant vector, or nil.
-DOCINDEX is the index of the doc string (or nil) in the FORM.
-If SPECINDEX is non-nil, it is the index in FORM
-of the function bytecode string. In that case,
-we output that argument and the following argument
-\(the constants vector) together, for lazy loading.
-QUOTED says that we have to put a quote before the
-list that represents a doc string reference.
-`defvaralias', `autoload' and `custom-declare-variable' need that."
- ;; We need to examine byte-compile-dynamic-docstrings
- ;; in the input buffer (now current), not in the output buffer.
- (let ((dynamic-docstrings byte-compile-dynamic-docstrings))
- (with-current-buffer byte-compile--outbuffer
- (let ((byte-compile-dynamic-docstrings dynamic-docstrings)
- (position (point))
- (print-continuous-numbering t)
- print-number-table
- ;; FIXME: The bindings below are only needed for when we're
- ;; called from ...-defmumble.
- (print-escape-newlines t)
- (print-length nil)
- (print-level nil)
- (print-quoted t)
- (print-gensym t)
- (print-circle t)) ; Handle circular data structures.
- (when preface
- ;; FIXME: We don't handle uninterned names correctly.
- ;; E.g. if cl-define-compiler-macro uses uninterned name we get:
- ;; (defalias '#1=#:foo--cmacro #[514 ...])
- ;; (put 'foo 'compiler-macro '#:foo--cmacro)
- (insert preface)
- (prin1 name byte-compile--outbuffer))
- (byte-compile--output-docform-recurse
- info position form cvecindex docindex specindex quoted)
- (when tailpiece
- (insert tailpiece))))))
-
(defun byte-compile-keep-pending (form &optional handler)
(if (memq byte-optimize '(t source))
(setq form (byte-optimize-one-form form t)))
@@ -2650,7 +2538,7 @@ list that represents a doc string reference.
(if byte-compile-output
(let ((form (byte-compile-out-toplevel t 'file)))
(cond ((eq (car-safe form) 'progn)
- (mapc 'byte-compile-output-file-form (cdr form)))
+ (mapc #'byte-compile-output-file-form (cdr form)))
(form
(byte-compile-output-file-form form)))
(setq byte-compile-constants nil
@@ -2725,12 +2613,12 @@ list that represents a doc string reference.
(setq byte-compile-unresolved-functions
(delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))
- (if (stringp (nth 3 form))
- (prog1
- form
- (byte-compile-docstring-style-warn form))
- ;; No doc string, so we can compile this as a normal form.
- (byte-compile-keep-pending form 'byte-compile-normal-call)))
+ (let* ((doc (nth 3 form))
+ (newdoc (if (not (stringp doc)) doc
+ (byte-compile--docstring
+ doc 'autoload (nth 1 form)))))
+ (byte-compile-keep-pending (byte-compile--list-with-n form 3 newdoc)
+ #'byte-compile-normal-call)))
(put 'defvar 'byte-hunk-handler 'byte-compile-file-form-defvar)
(put 'defconst 'byte-hunk-handler 'byte-compile-file-form-defvar)
@@ -2742,9 +2630,10 @@ list that represents a doc string reference.
(byte-compile-warn-x
sym "global/dynamic var `%s' lacks a prefix" sym)))
-(defun byte-compile--declare-var (sym)
+(defun byte-compile--declare-var (sym &optional not-toplevel)
(byte-compile--check-prefixed-var sym)
- (when (memq sym byte-compile-lexical-variables)
+ (when (and (not not-toplevel)
+ (memq sym byte-compile-lexical-variables))
(setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables))
(when (byte-compile-warning-enabled-p 'lexical sym)
@@ -2753,19 +2642,7 @@ list that represents a doc string reference.
(push sym byte-compile--seen-defvars))
(defun byte-compile-file-form-defvar (form)
- (let ((sym (nth 1 form)))
- (byte-compile--declare-var sym)
- (if (eq (car form) 'defconst)
- (push sym byte-compile-const-variables)))
- (if (and (null (cddr form)) ;No `value' provided.
- (eq (car form) 'defvar)) ;Just a declaration.
- nil
- (byte-compile-docstring-style-warn form)
- (setq form (copy-sequence form))
- (when (consp (nth 2 form))
- (setcar (cdr (cdr form))
- (byte-compile-top-level (nth 2 form) nil 'file)))
- form))
+ (byte-compile-defvar form 'toplevel))
(put 'define-abbrev-table 'byte-hunk-handler
'byte-compile-file-form-defvar-function)
@@ -2773,26 +2650,37 @@ list that represents a doc string reference.
(defun byte-compile-file-form-defvar-function (form)
(pcase-let (((or `',name (let name nil)) (nth 1 form)))
- (if name (byte-compile--declare-var name)))
- ;; Variable aliases are better declared before the corresponding variable,
- ;; since it makes it more likely that only one of the two vars has a value
- ;; before the `defvaralias' gets executed, which avoids the need to
- ;; merge values.
- (pcase form
- (`(defvaralias ,_ ',newname . ,_)
- (when (memq newname byte-compile-bound-variables)
- (if (byte-compile-warning-enabled-p 'suspicious)
- (byte-compile-warn-x
- newname
- "Alias for `%S' should be declared before its referent"
newname)))))
- (byte-compile-docstring-style-warn form)
- (byte-compile-keep-pending form))
+ (if name (byte-compile--declare-var name))
+ ;; Variable aliases are better declared before the corresponding variable,
+ ;; since it makes it more likely that only one of the two vars has a value
+ ;; before the `defvaralias' gets executed, which avoids the need to
+ ;; merge values.
+ (pcase form
+ (`(defvaralias ,_ ',newname . ,_)
+ (when (memq newname byte-compile-bound-variables)
+ (if (byte-compile-warning-enabled-p 'suspicious)
+ (byte-compile-warn-x
+ newname
+ "Alias for `%S' should be declared before its referent"
+ newname)))))
+ (let ((doc (nth 3 form)))
+ (when (stringp doc)
+ (setcar (nthcdr 3 form)
+ (byte-compile--docstring doc (nth 0 form) name))))
+ (byte-compile-keep-pending form)))
(put 'custom-declare-variable 'byte-hunk-handler
'byte-compile-file-form-defvar-function)
(put 'custom-declare-face 'byte-hunk-handler
- 'byte-compile-docstring-style-warn)
+ #'byte-compile--custom-declare-face)
+(defun byte-compile--custom-declare-face (form)
+ (let ((kind (nth 0 form)) (name (nth 1 form)) (docs (nth 3 form)))
+ (when (stringp docs)
+ (let ((newdocs (byte-compile--docstring docs kind name)))
+ (unless (eq docs newdocs)
+ (setq form (byte-compile--list-with-n form 3 newdocs)))))
+ form))
(put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
(defun byte-compile-file-form-require (form)
@@ -2946,34 +2834,24 @@ not to take responsibility for the actual compilation
of the code."
(cons (cons bare-name code)
(symbol-value this-kind))))
- (if rest
- ;; There are additional args to `defalias' (like maybe a docstring)
- ;; that the code below can't handle: punt!
- nil
- ;; Otherwise, we have a bona-fide defun/defmacro definition, and use
- ;; special code to allow dynamic docstrings and byte-code.
- (byte-compile-flush-pending)
+ (byte-compile-flush-pending)
+ (let ((newform `(defalias ',bare-name
+ ,(if macro `'(macro . ,code) code) ,@rest)))
(when byte-native-compiling
- ;; Spill output for the native compiler here.
+ ;; Don't let `byte-compile-output-file-form' push the form to
+ ;; `byte-to-native-top-level-forms' because we want to use
+ ;; `make-byte-to-native-func-def' when possible.
(push
- (if macro
+ (if (or macro rest)
(make-byte-to-native-top-level
- :form `(defalias ',name '(macro . ,code) nil)
+ :form newform
:lexical lexical-binding)
(make-byte-to-native-func-def :name name
:byte-func code))
byte-to-native-top-level-forms))
- ;; Output the form by hand, that's much simpler than having
- ;; b-c-output-file-form analyze the defalias.
- (byte-compile-output-docform
- "\n(defalias '" ")"
- bare-name
- (if macro '(" '(macro . #[" "])") '(" #[" "]"))
- (append code nil) ; Turn byte-code-function-p into list.
- 2 4
- (and (atom code) byte-compile-dynamic 1)
- nil)
- t)))))
+ (let ((byte-native-compiling nil))
+ (byte-compile-output-file-form newform)))
+ t))))
(defun byte-compile-output-as-comment (exp quoted)
"Print Lisp object EXP in the output file at point, inside a comment.
@@ -3018,18 +2896,10 @@ otherwise, print without quoting."
(defun byte-compile--reify-function (fun)
"Return an expression which will evaluate to a function value FUN.
-FUN should be either a `lambda' value or a `closure' value."
- (pcase-let* (((or (and `(lambda ,args . ,body) (let env nil))
- `(closure ,env ,args . ,body))
- fun)
- (preamble nil)
+FUN should be an interpreted closure."
+ (pcase-let* ((`(closure ,env ,args . ,body) fun)
+ (`(,preamble . ,body) (macroexp-parse-body body))
(renv ()))
- ;; Split docstring and `interactive' form from body.
- (when (stringp (car body))
- (push (pop body) preamble))
- (when (eq (car-safe (car body)) 'interactive)
- (push (pop body) preamble))
- (setq preamble (nreverse preamble))
;; Turn the function's closed vars (if any) into local let bindings.
(dolist (binding env)
(cond
@@ -3051,41 +2921,39 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(fun (if (symbolp form)
(symbol-function form)
form))
- (macro (eq (car-safe fun) 'macro)))
- (if macro
- (setq fun (cdr fun)))
- (prog1
- (cond
- ;; Up until Emacs-24.1, byte-compile silently did nothing
- ;; when asked to compile something invalid. So let's tone
- ;; down the complaint from an error to a simple message for
- ;; the known case where signaling an error causes problems.
- ((compiled-function-p fun)
- (message "Function %s is already compiled"
- (if (symbolp form) form "provided"))
- fun)
- (t
- (let (final-eval)
- (when (or (symbolp form) (eq (car-safe fun) 'closure))
- ;; `fun' is a function *value*, so try to recover its
corresponding
- ;; source code.
- (setq lexical-binding (eq (car fun) 'closure))
- (setq fun (byte-compile--reify-function fun))
- (setq final-eval t))
- ;; Expand macros.
- (setq fun (byte-compile-preprocess fun))
- (setq fun (byte-compile-top-level fun nil 'eval))
- (if (symbolp form)
- ;; byte-compile-top-level returns an *expression* equivalent
to the
- ;; `fun' expression, so we need to evaluate it, tho normally
- ;; this is not needed because the expression is just a
constant
- ;; byte-code object, which is self-evaluating.
- (setq fun (eval fun t)))
- (if final-eval
- (setq fun (eval fun t)))
- (if macro (push 'macro fun))
- (if (symbolp form) (fset form fun))
- fun))))))))
+ (macro (eq (car-safe fun) 'macro))
+ (need-a-value nil))
+ (when macro
+ (setq need-a-value t)
+ (setq fun (cdr fun)))
+ (cond
+ ;; Up until Emacs-24.1, byte-compile silently did nothing
+ ;; when asked to compile something invalid. So let's tone
+ ;; down the complaint from an error to a simple message for
+ ;; the known case where signaling an error causes problems.
+ ((compiled-function-p fun)
+ (message "Function %s is already compiled"
+ (if (symbolp form) form "provided"))
+ fun)
+ (t
+ (when (or (symbolp form) (eq (car-safe fun) 'closure))
+ ;; `fun' is a function *value*, so try to recover its
+ ;; corresponding source code.
+ (when (setq lexical-binding (eq (car-safe fun) 'closure))
+ (setq fun (byte-compile--reify-function fun)))
+ (setq need-a-value t))
+ ;; Expand macros.
+ (setq fun (byte-compile-preprocess fun))
+ (setq fun (byte-compile-top-level fun nil 'eval))
+ (when need-a-value
+ ;; `byte-compile-top-level' returns an *expression* equivalent to
+ ;; the `fun' expression, so we need to evaluate it, tho normally
+ ;; this is not needed because the expression is just a constant
+ ;; byte-code object, which is self-evaluating.
+ (setq fun (eval fun lexical-binding)))
+ (if macro (push 'macro fun))
+ (if (symbolp form) (fset form fun))
+ fun))))))
(defun byte-compile-sexp (sexp)
"Compile and return SEXP."
@@ -3184,9 +3052,9 @@ lambda-expression."
(setq fun (cons 'lambda fun))
(unless (eq 'lambda (car-safe fun))
(error "Not a lambda list: %S" fun)))
- (byte-compile-docstring-style-warn fun)
(byte-compile-check-lambda-list (nth 1 fun))
(let* ((arglist (nth 1 fun))
+ (bare-arglist (byte-run-strip-symbol-positions arglist)) ; for
compile-defun.
(arglistvars (byte-run-strip-symbol-positions
(byte-compile-arglist-vars arglist)))
(byte-compile-bound-variables
@@ -3195,16 +3063,22 @@ lambda-expression."
(body (cdr (cdr fun)))
(doc (if (stringp (car body))
(prog1 (car body)
- ;; Discard the doc string
+ ;; Discard the doc string from the body
;; unless it is the last element of the body.
(if (cdr body)
(setq body (cdr body))))))
(int (assq 'interactive body))
command-modes)
(when lexical-binding
+ (when arglist
+ ;; byte-compile-make-args-desc lost the args's names,
+ ;; so preserve them in the docstring.
+ (setq doc (help-add-fundoc-usage doc bare-arglist)))
(dolist (var arglistvars)
(when (assq var byte-compile--known-dynamic-vars)
(byte-compile--warn-lexical-dynamic var 'lambda))))
+ (when (stringp doc)
+ (setq doc (byte-compile--docstring doc "" nil 'is-a-value)))
;; Process the interactive spec.
(when int
;; Skip (interactive) if it is in front (the most usual location).
@@ -3248,8 +3122,7 @@ lambda-expression."
(and lexical-binding
(byte-compile-make-lambda-lexenv
arglistvars))
- reserved-csts))
- (bare-arglist (byte-run-strip-symbol-positions arglist))) ; for
compile-defun.
+ reserved-csts)))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
(let ((out
@@ -3261,12 +3134,7 @@ lambda-expression."
;; byte-string, constants-vector, stack depth
(cdr compiled)
;; optionally, the doc string.
- (cond ((and lexical-binding arglist)
- ;; byte-compile-make-args-desc lost the args's
names,
- ;; so preserve them in the docstring.
- (list (help-add-fundoc-usage doc bare-arglist)))
- ((or doc int)
- (list doc)))
+ (when (or doc int) (list doc))
;; optionally, the interactive spec (and the modes the
;; command applies to).
(cond
@@ -3820,7 +3688,6 @@ lambda-expression."
(alen (length (cdr form)))
(dynbinds ())
lap)
- (fetch-bytecode fun)
(setq lap (byte-decompile-bytecode-1 (aref fun 1) (aref fun 2) t))
;; optimized switch bytecode makes it impossible to guess the correct
;; `byte-compile-depth', which can result in incorrect inlined code.
@@ -5147,49 +5014,49 @@ binding slots have been popped."
(push (nth 1 (nth 1 form)) byte-compile-global-not-obsolete-vars))
(byte-compile-normal-call form))
-(defun byte-compile-defvar (form)
- ;; This is not used for file-level defvar/consts.
- (when (and (symbolp (nth 1 form))
- (not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
- (byte-compile-warning-enabled-p 'lexical (nth 1 form)))
- (byte-compile-warn-x
- (nth 1 form)
- "global/dynamic var `%s' lacks a prefix"
- (nth 1 form)))
- (byte-compile-docstring-style-warn form)
- (let ((fun (nth 0 form))
- (var (nth 1 form))
- (value (nth 2 form))
- (string (nth 3 form)))
- (when (or (> (length form) 4)
- (and (eq fun 'defconst) (null (cddr form))))
- (let ((ncall (length (cdr form))))
- (byte-compile-warn-x
- fun
- "`%s' called with %d argument%s, but %s %s"
- fun ncall
- (if (= 1 ncall) "" "s")
- (if (< ncall 2) "requires" "accepts only")
- "2-3")))
- (push var byte-compile-bound-variables)
+(defun byte-compile-defvar (form &optional toplevel)
+ (let* ((fun (nth 0 form))
+ (var (nth 1 form))
+ (value (nth 2 form))
+ (string (nth 3 form)))
+ (byte-compile--declare-var var (not toplevel))
(if (eq fun 'defconst)
(push var byte-compile-const-variables))
- (when (and string (not (stringp string)))
+ (cond
+ ((stringp string)
+ (setq string (byte-compile--docstring string fun var 'is-a-value)))
+ (string
(byte-compile-warn-x
string
"third arg to `%s %s' is not a string: %s"
- fun var string))
- ;; Delegate the actual work to the function version of the
- ;; special form, named with a "-1" suffix.
- (byte-compile-form-do-effect
- (cond
- ((eq fun 'defconst) `(defconst-1 ',var ,@(nthcdr 2 form)))
- ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo.
- (t `(defvar-1 ',var
- ;; Don't eval `value' if `defvar' wouldn't eval it either.
- ,(if (macroexp-const-p value) value
- `(if (boundp ',var) nil ,value))
- ,@(nthcdr 3 form)))))))
+ fun var string)))
+ (if toplevel
+ ;; At top-level we emit calls to defvar/defconst.
+ (if (and (null (cddr form)) ;No `value' provided.
+ (eq (car form) 'defvar)) ;Just a declaration.
+ nil
+ (let ((tail (nthcdr 4 form)))
+ (when (or tail string) (push string tail))
+ (when (cddr form)
+ (push (if (not (consp value)) value
+ (byte-compile-top-level value nil 'file))
+ tail))
+ `(,fun ,var ,@tail)))
+ ;; At non-top-level, since there is no byte code for
+ ;; defvar/defconst, we delegate the actual work to the function
+ ;; version of the special form, named with a "-1" suffix.
+ (byte-compile-form-do-effect
+ (cond
+ ((eq fun 'defconst)
+ `(defconst-1 ',var ,@(byte-compile--list-with-n
+ (nthcdr 2 form) 1 (macroexp-quote string))))
+ ((not (cddr form)) `',var) ; A simple (defvar foo) just returns foo.
+ (t `(defvar-1 ',var
+ ;; Don't eval `value' if `defvar' wouldn't eval it
either.
+ ,(if (macroexp-const-p value) value
+ `(if (boundp ',var) nil ,value))
+ ,@(byte-compile--list-with-n
+ (nthcdr 3 form) 0 (macroexp-quote string)))))))))
(defun byte-compile-autoload (form)
(and (macroexp-const-p (nth 1 form))
@@ -5215,14 +5082,6 @@ binding slots have been popped."
;; For the compilation itself, we could largely get rid of this hunk-handler,
;; if it weren't for the fact that we need to figure out when a defalias
;; defines a macro, so as to add it to byte-compile-macro-environment.
- ;;
- ;; FIXME: we also use this hunk-handler to implement the function's
- ;; dynamic docstring feature (via byte-compile-file-form-defmumble).
- ;; We should probably actually implement it (more elegantly) in
- ;; byte-compile-lambda so it applies to all lambdas. We did it here
- ;; so the resulting .elc format was recognizable by make-docfile,
- ;; but since then we stopped using DOC for the docstrings of
- ;; preloaded elc files so that obstacle is gone.
(let ((byte-compile-free-references nil)
(byte-compile-free-assignments nil))
(pcase form
@@ -5231,7 +5090,11 @@ binding slots have been popped."
;; - `arg' is the expression to which it is defined.
;; - `rest' is the rest of the arguments.
(`(,_ ',name ,arg . ,rest)
- (byte-compile-docstring-style-warn form)
+ (let ((doc (car rest)))
+ (when (stringp doc)
+ (setq rest (byte-compile--list-with-n
+ rest 0
+ (byte-compile--docstring doc (nth 0 form) name)))))
(pcase-let*
;; `macro' is non-nil if it defines a macro.
;; `fun' is the function part of `arg' (defaults to `arg').
@@ -5900,6 +5763,16 @@ and corresponding effects."
(eval form)
form)))
+;; Report comma operator used outside of backquote.
+;; Inside backquote, backquote will transform it before it gets here.
+
+(put '\, 'compiler-macro #'bytecomp--report-comma)
+(defun bytecomp--report-comma (form &rest _ignore)
+ (macroexp-warn-and-return
+ (format-message "`%s' called -- perhaps used not within backquote"
+ (car form))
+ form (list 'suspicious (car form)) t))
+
;; Check for (in)comparable constant values in calls to `eq', `memq' etc.
(defun bytecomp--dodgy-eq-arg-p (x number-ok)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index e210cfdf5ce..4ff47971351 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -621,12 +621,16 @@ places where they originally did not directly appear."
(cconv-convert exp env extend))
(`(,func . ,forms)
- (if (symbolp func)
+ (if (or (symbolp func) (functionp func))
;; First element is function or whatever function-like forms are:
;; or, and, if, catch, progn, prog1, while, until
- `(,func . ,(mapcar (lambda (form)
- (cconv-convert form env extend))
- forms))
+ (let ((args (mapcar (lambda (form) (cconv-convert form env extend))
+ forms)))
+ (unless (symbolp func)
+ (byte-compile-warn-x
+ form
+ "Use `funcall' instead of `%s' in the function position" func))
+ `(,func . ,args))
(byte-compile-warn-x form "Malformed function `%S'" func)
nil))
diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el
index 8e40b227b65..faa7824c8bd 100644
--- a/lisp/emacs-lisp/check-declare.el
+++ b/lisp/emacs-lisp/check-declare.el
@@ -85,6 +85,9 @@ don't know how to recognize (e.g. some macros)."
(let (alist)
(with-temp-buffer
(insert-file-contents file)
+ ;; Ensure shorthands available, as we will be `read'ing Elisp
+ ;; (bug#67523)
+ (let (enable-local-variables) (hack-local-variables))
;; FIXME we could theoretically be inside a string.
(while (re-search-forward "^[ \t]*\\((declare-function\\)[ \t\n]" nil t)
(let ((pos (match-beginning 1)))
@@ -145,64 +148,70 @@ is a string giving details of the error."
(if (file-regular-p fnfile)
(with-temp-buffer
(insert-file-contents fnfile)
+ (unless cflag
+ ;; If in Elisp, ensure syntax and shorthands available
+ ;; (bug#67523)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (let (enable-local-variables) (hack-local-variables)))
;; defsubst's don't _have_ to be known at compile time.
- (setq re (format (if cflag
- "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\""
- "^[ \t]*(\\(fset[ \t]+'\\|\
+ (setq re (if cflag
+ (format "^[ \t]*\\(DEFUN\\)[ \t]*([ \t]*\"%s\""
+ (regexp-opt (mapcar 'cadr fnlist) t))
+ "^[ \t]*(\\(fset[ \t]+'\\|\
cl-def\\(?:generic\\|method\\|un\\)\\|\
def\\(?:un\\|subst\\|foo\\|method\\|class\\|\
ine-\\(?:derived\\|generic\\|\\(?:global\\(?:ized\\)?-\\)?minor\\)-mode\\|\
\\(?:ine-obsolete-function-\\)?alias[ \t]+'\\|\
ine-overloadable-function\\)\\)\
-[ \t]*%s\\([ \t;]+\\|$\\)")
- (regexp-opt (mapcar 'cadr fnlist) t)))
+[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)\\([ \t;]+\\|$\\)"))
(while (re-search-forward re nil t)
(skip-chars-forward " \t\n")
- (setq fn (match-string 2)
- type (match-string 1)
- ;; (min . max) for a fixed number of arguments, or
- ;; arglists with optional elements.
- ;; (min) for arglists with &rest.
- ;; sig = 'err means we could not find an arglist.
- sig (cond (cflag
- (or
- (when (search-forward "," nil t 3)
- (skip-chars-forward " \t\n")
- ;; Assuming minargs and maxargs on same line.
- (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\
+ (setq fn (symbol-name (car (read-from-string (match-string 2)))))
+ (when (member fn (mapcar 'cadr fnlist))
+ (setq type (match-string 1)
+ ;; (min . max) for a fixed number of arguments, or
+ ;; arglists with optional elements.
+ ;; (min) for arglists with &rest.
+ ;; sig = 'err means we could not find an arglist.
+ sig (cond (cflag
+ (or
+ (when (search-forward "," nil t 3)
+ (skip-chars-forward " \t\n")
+ ;; Assuming minargs and maxargs on same line.
+ (when (looking-at "\\([0-9]+\\)[ \t]*,[ \t]*\
\\([0-9]+\\|MANY\\|UNEVALLED\\)")
- (setq minargs (string-to-number
- (match-string 1))
- maxargs (match-string 2))
- (cons minargs (unless (string-match "[^0-9]"
- maxargs)
- (string-to-number
- maxargs)))))
- 'err))
- ((string-match
- "\\`define-\\(derived\\|generic\\)-mode\\'"
- type)
- '(0 . 0))
- ((string-match
-
"\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'"
- type)
- '(0 . 1))
- ;; Prompt to update.
- ((string-match
- "\\`define-obsolete-function-alias\\>"
- type)
- 'obsolete)
- ;; Can't easily check arguments in these cases.
- ((string-match "\\`\\(def\\(alias\\|class\\)\\|\
+ (setq minargs (string-to-number
+ (match-string 1))
+ maxargs (match-string 2))
+ (cons minargs (unless (string-match
"[^0-9]"
+
maxargs)
+ (string-to-number
+ maxargs)))))
+ 'err))
+ ((string-match
+ "\\`define-\\(derived\\|generic\\)-mode\\'"
+ type)
+ '(0 . 0))
+ ((string-match
+
"\\`define\\(-global\\(ized\\)?\\)?-minor-mode\\'"
+ type)
+ '(0 . 1))
+ ;; Prompt to update.
+ ((string-match
+ "\\`define-obsolete-function-alias\\>"
+ type)
+ 'obsolete)
+ ;; Can't easily check arguments in these cases.
+ ((string-match "\\`\\(def\\(alias\\|class\\)\\|\
fset\\|\\(?:cl-\\)?defmethod\\)\\>" type)
- t)
- ((looking-at "\\((\\|nil\\)")
- (byte-compile-arglist-signature
- (read (current-buffer))))
- (t
- 'err))
- ;; alist of functions and arglist signatures.
- siglist (cons (cons fn sig) siglist)))))
+ t)
+ ((looking-at "\\((\\|nil\\)")
+ (byte-compile-arglist-signature
+ (read (current-buffer))))
+ (t
+ 'err))
+ ;; alist of functions and arglist signatures.
+ siglist (cons (cons fn sig) siglist))))))
(dolist (e fnlist)
(setq arglist (nth 2 e)
type
@@ -319,9 +328,14 @@ Returns non-nil if any false statements are found."
(setq root (directory-file-name (file-relative-name root)))
(or (file-directory-p root)
(error "Directory `%s' not found" root))
- (let ((files (directory-files-recursively root "\\.el\\'")))
- (when files
- (apply #'check-declare-files files))))
+ (when-let* ((files (directory-files-recursively root "\\.el\\'"))
+ (files (mapcan (lambda (file)
+ ;; Filter out lock files.
+ (and (not (string-prefix-p
+ ".#" (file-name-nondirectory file)))
+ (list file)))
+ files)))
+ (apply #'check-declare-files files)))
(provide 'check-declare)
diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el
index 82c6c03a592..02c11cae573 100644
--- a/lisp/emacs-lisp/checkdoc.el
+++ b/lisp/emacs-lisp/checkdoc.el
@@ -1994,7 +1994,7 @@ from the comment."
(defun-depth (ppss-depth (syntax-ppss)))
(lst nil)
(ret nil)
- (oo (make-vector 3 0))) ;substitute obarray for `read'
+ (oo (obarray-make 3))) ;substitute obarray for `read'
(forward-char 1)
(forward-sexp 1)
(skip-chars-forward " \n\t")
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index bdccdcc48ce..f439a97f88c 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1140,12 +1140,8 @@ MET-NAME is as returned by
`cl--generic-load-hist-format'."
(add-hook 'help-fns-describe-function-functions #'cl--generic-describe)
(defun cl--generic-describe (function)
- ;; Supposedly this is called from help-fns, so help-fns should be loaded at
- ;; this point.
- (declare-function help-fns-short-filename "help-fns" (filename))
(let ((generic (if (symbolp function) (cl--generic function))))
(when generic
- (require 'help-mode) ;Needed for `help-function-def' button!
(save-excursion
;; Ensure that we have two blank lines (but not more).
(unless (looking-back "\n\n" (- (point) 2))
@@ -1153,33 +1149,49 @@ MET-NAME is as returned by
`cl--generic-load-hist-format'."
(insert "This is a generic function.\n\n")
(insert (propertize "Implementations:\n\n" 'face 'bold))
;; Loop over fanciful generics
- (dolist (method (cl--generic-method-table generic))
- (pcase-let*
- ((`(,qualifiers ,args ,doc) (cl--generic-method-info method)))
- ;; FIXME: Add hyperlinks for the types as well.
- (let ((print-quoted nil)
- (quals (if (length> qualifiers 0)
- (concat (substring qualifiers
- 0 (string-match " *\\'"
- qualifiers))
- "\n")
- "")))
- (insert (format "%s%S"
- quals
- (cons function
- (cl--generic-upcase-formal-args args)))))
- (let* ((met-name (cl--generic-load-hist-format
- function
- (cl--generic-method-qualifiers method)
- (cl--generic-method-specializers method)))
- (file (find-lisp-object-file-name met-name 'cl-defmethod)))
- (when file
- (insert (substitute-command-keys " in `"))
- (help-insert-xref-button (help-fns-short-filename file)
- 'help-function-def met-name file
- 'cl-defmethod)
- (insert (substitute-command-keys "'.\n"))))
- (insert "\n" (or doc "Undocumented") "\n\n")))))))
+ (cl--map-methods-documentation
+ function
+ (lambda (quals signature file doc)
+ (insert (format "%s%S%s\n\n%s\n\n"
+ quals signature
+ (if file (format-message " in `%s'." file) "")
+ (or doc "Undocumented")))))))))
+
+(defun cl--map-methods-documentation (funname metname-printer)
+ "Iterate on FUNNAME's methods documentation at point."
+ ;; Supposedly this is called from help-fns, so help-fns should be loaded at
+ ;; this point.
+ (require 'help-fns)
+ (declare-function help-fns-short-filename "help-fns" (filename))
+ (let ((generic (if (symbolp funname) (cl--generic funname))))
+ (when generic
+ (require 'help-mode) ;Needed for `help-function-def' button!
+ ;; Loop over fanciful generics
+ (dolist (method (cl--generic-method-table generic))
+ (pcase-let*
+ ((`(,qualifiers ,args ,doc) (cl--generic-method-info method))
+ ;; FIXME: Add hyperlinks for the types as well.
+ (quals (if (length> qualifiers 0)
+ (concat (substring qualifiers
+ 0 (string-match " *\\'"
+ qualifiers))
+ "\n")
+ ""))
+ (met-name (cl--generic-load-hist-format
+ funname
+ (cl--generic-method-qualifiers method)
+ (cl--generic-method-specializers method)))
+ (file (find-lisp-object-file-name met-name 'cl-defmethod)))
+ (funcall metname-printer
+ quals
+ (cons funname
+ (cl--generic-upcase-formal-args args))
+ (when file
+ (make-text-button (help-fns-short-filename file) nil
+ 'type 'help-function-def
+ 'help-args
+ (list met-name file 'cl-defmethod)))
+ doc))))))
(defun cl--generic-specializers-apply-to-type-p (specializers type)
"Return non-nil if a method with SPECIALIZERS applies to TYPE."
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 88447203a64..be477b7a6df 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3344,14 +3344,14 @@ Elements of FIELDS can be of the form (NAME PAT) in
which case the
contents of field NAME is matched against PAT, or they can be of
the form NAME which is a shorthand for (NAME NAME)."
(declare (debug (sexp &rest [&or (sexp pcase-PAT) sexp])))
- `(and (pred (pcase--flip cl-typep ',type))
+ `(and (pred (cl-typep _ ',type))
,@(mapcar
(lambda (field)
(let* ((name (if (consp field) (car field) field))
(pat (if (consp field) (cadr field) field)))
`(app ,(if (eq (cl-struct-sequence-type type) 'list)
`(nth ,(cl-struct-slot-offset type name))
- `(pcase--flip aref ,(cl-struct-slot-offset type name)))
+ `(aref _ ,(cl-struct-slot-offset type name)))
,pat)))
fields)))
@@ -3368,13 +3368,13 @@ the form NAME which is a shorthand for (NAME NAME)."
"Extra special cases for `cl-typep' predicates."
(let* ((x1 pred1) (x2 pred2)
(t1
- (and (eq 'pcase--flip (car-safe x1)) (setq x1 (cdr x1))
- (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1))
+ (and (eq 'cl-typep (car-safe x1)) (setq x1 (cdr x1))
+ (eq '_ (car-safe x1)) (setq x1 (cdr x1))
(null (cdr-safe x1)) (setq x1 (car x1))
(eq 'quote (car-safe x1)) (cadr x1)))
(t2
- (and (eq 'pcase--flip (car-safe x2)) (setq x2 (cdr x2))
- (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2))
+ (and (eq 'cl-typep (car-safe x2)) (setq x2 (cdr x2))
+ (eq '_ (car-safe x2)) (setq x2 (cdr x2))
(null (cdr-safe x2)) (setq x2 (car x2))
(eq 'quote (car-safe x2)) (cadr x2))))
(or
@@ -3460,6 +3460,7 @@ Of course, we really can't know that for sure, so it's
just a heuristic."
(or (cdr (assq sym byte-compile-function-environment))
(cdr (assq sym macroexpand-all-environment))))))
+;; Please keep it in sync with `comp-known-predicates'.
(pcase-dolist (`(,type . ,pred)
;; Mostly kept in alphabetical order.
'((array . arrayp)
@@ -3487,6 +3488,7 @@ Of course, we really can't know that for sure, so it's
just a heuristic."
(natnum . natnump)
(number . numberp)
(null . null)
+ (obarray . obarrayp)
(overlay . overlayp)
(process . processp)
(real . numberp)
@@ -3494,6 +3496,7 @@ Of course, we really can't know that for sure, so it's
just a heuristic."
(subr . subrp)
(string . stringp)
(symbol . symbolp)
+ (symbol-with-pos . symbol-with-pos-p)
(vector . vectorp)
(window . windowp)
;; FIXME: Do we really want to consider these types?
@@ -3818,7 +3821,8 @@ STRUCT-TYPE and SLOT-NAME are symbols. INST is a
structure instance."
(pcase-defmacro cl-type (type)
"Pcase pattern that matches objects of TYPE.
TYPE is a type descriptor as accepted by `cl-typep', which see."
- `(pred (pcase--flip cl-typep ',type)))
+ `(pred (cl-typep _ ',type)))
+
;; Local variables:
;; generated-autoload-file: "cl-loaddefs.el"
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index 0b30e10b344..fb06b127676 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -62,7 +62,7 @@
tree-sitter-parser user-ptr font-object font-entity font-spec
condvar mutex thread terminal hash-table frame buffer function
window process window-configuration overlay integer-or-marker
- number-or-marker symbol array)
+ number-or-marker symbol array obarray)
(number float integer)
(number-or-marker marker number)
(integer bignum fixnum)
diff --git a/lisp/emacs-lisp/comp-common.el b/lisp/emacs-lisp/comp-common.el
index 6ba9664ea5c..221f819e474 100644
--- a/lisp/emacs-lisp/comp-common.el
+++ b/lisp/emacs-lisp/comp-common.el
@@ -240,7 +240,8 @@ Used to modify the compiler environment."
(integer-or-marker-p (function (t) boolean))
(integerp (function (t) boolean))
(interactive-p (function () boolean))
- (intern-soft (function ((or string symbol) &optional vector) symbol))
+ (intern-soft (function ((or string symbol) &optional (or obarray vector))
+ symbol))
(invocation-directory (function () string))
(invocation-name (function () string))
(isnan (function (float) boolean))
@@ -309,7 +310,7 @@ Used to modify the compiler environment."
(numberp (function (t) boolean))
(one-window-p (function (&optional t t) boolean))
(overlayp (function (t) boolean))
- (parse-colon-path (function (string) cons))
+ (parse-colon-path (function (string) list))
(plist-get (function (list t &optional t) t))
(plist-member (function (list t &optional t) list))
(point (function () integer))
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 0a8b3b7efb2..55d92841cd5 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -44,7 +44,7 @@
;; TODO can we just add t in `cl--typeof-types'?
"Like `cl--typeof-types' but with t as common supertype.")
-(cl-defstruct (comp-cstr (:constructor comp-type-to-cstr
+(cl-defstruct (comp-cstr (:constructor comp--type-to-cstr
(type &aux
(null (eq type 'null))
(integer (eq type 'integer))
@@ -55,7 +55,7 @@
'(nil)))
(range (when integer
'((- . +))))))
- (:constructor comp-value-to-cstr
+ (:constructor comp--value-to-cstr
(value &aux
(integer (integerp value))
(valset (unless integer
@@ -63,7 +63,7 @@
(range (when integer
`((,value . ,value))))
(typeset ())))
- (:constructor comp-irange-to-cstr
+ (:constructor comp--irange-to-cstr
(irange &aux
(range (list irange))
(typeset ())))
@@ -229,10 +229,10 @@ Return them as multiple value."
;; builds.
(defvar comp-ctxt nil)
-(defvar comp-cstr-one (comp-value-to-cstr 1)
+(defvar comp-cstr-one (comp--value-to-cstr 1)
"Represent the integer immediate one.")
-(defvar comp-cstr-t (comp-type-to-cstr t)
+(defvar comp-cstr-t (comp--type-to-cstr t)
"Represent the superclass t.")
@@ -249,6 +249,8 @@ Return them as multiple value."
t)
((and (not (symbolp x)) (symbolp y))
nil)
+ ((or (consp x) (consp y)
+ nil))
(t
(< (sxhash-equal x)
(sxhash-equal y)))))))
@@ -1211,14 +1213,14 @@ FN non-nil indicates we are parsing a function lambda
list."
('nil
(make-comp-cstr :typeset ()))
('fixnum
- (comp-irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum)))
+ (comp--irange-to-cstr `(,most-negative-fixnum . ,most-positive-fixnum)))
('boolean
(comp-type-spec-to-cstr '(member t nil)))
('integer
- (comp-irange-to-cstr '(- . +)))
- ('null (comp-value-to-cstr nil))
+ (comp--irange-to-cstr '(- . +)))
+ ('null (comp--value-to-cstr nil))
((pred atom)
- (comp-type-to-cstr type-spec))
+ (comp--type-to-cstr type-spec))
(`(or . ,rest)
(apply #'comp-cstr-union-make
(mapcar #'comp-type-spec-to-cstr rest)))
@@ -1228,16 +1230,16 @@ FN non-nil indicates we are parsing a function lambda
list."
(`(not ,cstr)
(comp-cstr-negation-make (comp-type-spec-to-cstr cstr)))
(`(integer ,(and (pred integerp) l) ,(and (pred integerp) h))
- (comp-irange-to-cstr `(,l . ,h)))
+ (comp--irange-to-cstr `(,l . ,h)))
(`(integer * ,(and (pred integerp) h))
- (comp-irange-to-cstr `(- . ,h)))
+ (comp--irange-to-cstr `(- . ,h)))
(`(integer ,(and (pred integerp) l) *)
- (comp-irange-to-cstr `(,l . +)))
+ (comp--irange-to-cstr `(,l . +)))
(`(float ,(pred comp-star-or-num-p) ,(pred comp-star-or-num-p))
;; No float range support :/
- (comp-type-to-cstr 'float))
+ (comp--type-to-cstr 'float))
(`(member . ,rest)
- (apply #'comp-cstr-union-make (mapcar #'comp-value-to-cstr rest)))
+ (apply #'comp-cstr-union-make (mapcar #'comp--value-to-cstr rest)))
(`(function ,args ,ret)
(make-comp-cstr-f
:args (mapcar (lambda (x)
diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el
index 5d1a193269d..8fcbe31cf0b 100644
--- a/lisp/emacs-lisp/comp-run.el
+++ b/lisp/emacs-lisp/comp-run.el
@@ -25,7 +25,7 @@
;; 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
+;; processes performing async compilation. This file contains all
;; the code needed to drive async compilations and any Lisp code
;; needed at runtime to run native code.
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 8441b228898..21e2bb01ed0 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -43,7 +43,7 @@
(defvar native-comp-eln-load-path)
(defvar native-comp-enable-subr-trampolines)
-(declare-function comp--compile-ctxt-to-file "comp.c")
+(declare-function comp--compile-ctxt-to-file0 "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")
@@ -68,7 +68,7 @@
:safe #'integerp
:version "28.1")
-(defcustom native-comp-debug 0
+(defcustom native-comp-debug 0
"Debug level for native compilation, a number between 0 and 3.
This is intended for debugging the compiler itself.
0 no debug output.
@@ -155,17 +155,18 @@ native compilation runs.")
"Current allocation class.
Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.")
-(defconst comp-passes '(comp-spill-lap
- comp-limplify
- comp-fwprop
- comp-call-optim
- comp-ipa-pure
- comp-add-cstrs
- comp-fwprop
- comp-tco
- comp-fwprop
- comp-remove-type-hints
- comp-final)
+(defconst comp-passes '(comp--spill-lap
+ comp--limplify
+ comp--fwprop
+ comp--call-optim
+ comp--ipa-pure
+ comp--add-cstrs
+ comp--fwprop
+ comp--tco
+ comp--fwprop
+ comp--remove-type-hints
+ comp--compute-function-types
+ comp--final)
"Passes to be executed in order.")
(defvar comp-disabled-passes '()
@@ -187,31 +188,42 @@ Useful to hook into pass checkers.")
finally return h)
"Hash table function -> `comp-constraint'.")
+;; Keep it in sync with the `cl-deftype-satisfies' property set in
+;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the
+;; relation type <-> predicate is not bijective (bug#45576).
(defconst comp-known-predicates
'((arrayp . array)
(atom . atom)
- (characterp . fixnum)
- (booleanp . boolean)
(bool-vector-p . bool-vector)
+ (booleanp . boolean)
(bufferp . buffer)
- (natnump . (integer 0 *))
(char-table-p . char-table)
- (hash-table-p . hash-table)
+ (characterp . fixnum)
(consp . cons)
- (integerp . integer)
(floatp . float)
+ (framep . frame)
(functionp . (or function symbol))
+ (hash-table-p . hash-table)
+ (integer-or-marker-p . integer-or-marker)
(integerp . integer)
(keywordp . keyword)
(listp . list)
- (numberp . number)
+ (markerp . marker)
+ (natnump . (integer 0 *))
(null . null)
+ (number-or-marker-p . number-or-marker)
(numberp . number)
+ (numberp . number)
+ (obarrayp . obarray)
+ (overlayp . overlay)
+ (processp . process)
(sequencep . sequence)
(stringp . string)
+ (subrp . subr)
+ (symbol-with-pos-p . symbol-with-pos)
(symbolp . symbol)
(vectorp . vector)
- (integer-or-marker-p . integer-or-marker))
+ (windowp . window))
"Alist predicate -> matched type specifier.")
(defconst comp-known-predicates-h
@@ -388,7 +400,7 @@ This is typically for top-level forms other than defun.")
(closed nil :type boolean
:documentation "t if closed.")
;; All the following are for SSA and CGF analysis.
- ;; Keep in sync with `comp-clean-ssa'!!
+ ;; Keep in sync with `comp--clean-ssa'!!
(in-edges () :type list
:documentation "List of incoming edges.")
(out-edges () :type list
@@ -416,7 +428,7 @@ into it.")
:documentation "Start block LAP address.")
(non-ret-insn nil :type list
:documentation "Insn known to perform a non local exit.
-`comp-fwprop' may identify and store here basic blocks performing
+`comp--fwprop' may identify and store here basic blocks performing
non local exits and mark it rewrite it later.")
(no-ret nil :type boolean
:documentation "t when the block is known to perform a
@@ -507,7 +519,7 @@ CFG is mutated by a pass.")
(lambda-list nil :type list
:documentation "Original lambda-list."))
-(cl-defstruct (comp-mvar (:constructor make--comp-mvar)
+(cl-defstruct (comp-mvar (:constructor make--comp-mvar0)
(:include comp-cstr))
"A meta-variable being a slot in the meta-stack."
(id nil :type (or null number)
@@ -516,6 +528,7 @@ CFG is mutated by a pass.")
:documentation "Slot number in the array if a number or
`scratch' for scratch slot."))
+;; In use by comp.c.
(defun comp-mvar-type-hint-match-p (mvar type-hint)
"Match MVAR against TYPE-HINT.
In use by the back-end."
@@ -569,10 +582,9 @@ In use by the back-end."
finally return t)
t))
-(defsubst comp--symbol-func-to-fun (symbol-funcion)
- "Given a function called SYMBOL-FUNCION return its `comp-func'."
- (gethash (gethash symbol-funcion (comp-ctxt-sym-to-c-name-h
- comp-ctxt))
+(defsubst comp--symbol-func-to-fun (symbol-func)
+ "Given a function called SYMBOL-FUNC return its `comp-func'."
+ (gethash (gethash symbol-func (comp-ctxt-sym-to-c-name-h comp-ctxt))
(comp-ctxt-funcs-h comp-ctxt)))
(defun comp--function-pure-p (f)
@@ -637,7 +649,7 @@ VERBOSITY is a number between 0 and 3."
-(defmacro comp-loop-insn-in-block (basic-block &rest body)
+(defmacro comp--loop-insn-in-block (basic-block &rest body)
"Loop over all insns in BASIC-BLOCK executing BODY.
Inside BODY, `insn' and `insn-cell'can be used to read or set the
current instruction or its cell."
@@ -651,19 +663,19 @@ current instruction or its cell."
;;; spill-lap pass specific code.
-(defun comp-lex-byte-func-p (f)
+(defun comp--lex-byte-func-p (f)
"Return t if F is a lexically-scoped byte compiled function."
(and (byte-code-function-p f)
(fixnump (aref f 0))))
-(defun comp-spill-decl-spec (function-name spec)
+(defun comp--spill-decl-spec (function-name spec)
"Return the declared specifier SPEC for FUNCTION-NAME."
(plist-get (cdr (assq function-name byte-to-native-plist-environment))
spec))
-(defun comp-spill-speed (function-name)
+(defun comp--spill-speed (function-name)
"Return the speed for FUNCTION-NAME."
- (or (comp-spill-decl-spec function-name 'speed)
+ (or (comp--spill-decl-spec function-name 'speed)
(comp-ctxt-speed comp-ctxt)))
;; Autoloaded as might be used by `disassemble-internal'.
@@ -702,7 +714,7 @@ clashes."
;; pick the first one.
(concat prefix crypted "_" human-readable "_0"))))
-(defun comp-decrypt-arg-list (x function-name)
+(defun comp--decrypt-arg-list (x function-name)
"Decrypt argument list X for FUNCTION-NAME."
(unless (fixnump x)
(signal 'native-compiler-error-dyn-func (list function-name)))
@@ -717,21 +729,21 @@ clashes."
:nonrest nonrest
:rest rest))))
-(defsubst comp-byte-frame-size (byte-compiled-func)
+(defsubst comp--byte-frame-size (byte-compiled-func)
"Return the frame size to be allocated for BYTE-COMPILED-FUNC."
(aref byte-compiled-func 3))
-(defun comp-add-func-to-ctxt (func)
+(defun comp--add-func-to-ctxt (func)
"Add FUNC to the current compiler context."
(let ((name (comp-func-name func))
(c-name (comp-func-c-name func)))
(puthash name c-name (comp-ctxt-sym-to-c-name-h comp-ctxt))
(puthash c-name func (comp-ctxt-funcs-h comp-ctxt))))
-(cl-defgeneric comp-spill-lap-function (input)
+(cl-defgeneric comp--spill-lap-function (input)
"Byte-compile INPUT and spill lap for further stages.")
-(cl-defmethod comp-spill-lap-function ((function-name symbol))
+(cl-defmethod comp--spill-lap-function ((function-name symbol))
"Byte-compile FUNCTION-NAME, spilling data from the byte compiler."
(unless (comp-ctxt-output comp-ctxt)
(setf (comp-ctxt-output comp-ctxt)
@@ -747,9 +759,9 @@ clashes."
(list (make-byte-to-native-func-def :name function-name
:c-name c-name
:byte-func byte-code)))
- (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)))
+ (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h)))
-(cl-defmethod comp-spill-lap-function ((form list))
+(cl-defmethod comp--spill-lap-function ((form list))
"Byte-compile FORM, spilling data from the byte compiler."
(unless (memq (car-safe form) '(lambda closure))
(signal 'native-compiler-error
@@ -763,9 +775,9 @@ clashes."
(list (make-byte-to-native-func-def :name '--anonymous-lambda
:c-name c-name
:byte-func byte-code)))
- (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h)))
+ (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h)))
-(defun comp-intern-func-in-ctxt (_ obj)
+(defun comp--intern-func-in-ctxt (_ obj)
"Given OBJ of type `byte-to-native-lambda', create a function in
`comp-ctxt'."
(when-let ((byte-func (byte-to-native-lambda-byte-func obj)))
(let* ((lap (byte-to-native-lambda-lap obj))
@@ -778,9 +790,9 @@ clashes."
(name (when top-l-form
(byte-to-native-func-def-name top-l-form)))
(c-name (comp-c-func-name (or name "anonymous-lambda") "F"))
- (func (if (comp-lex-byte-func-p byte-func)
+ (func (if (comp--lex-byte-func-p byte-func)
(make-comp-func-l
- :args (comp-decrypt-arg-list (aref byte-func 0)
+ :args (comp--decrypt-arg-list (aref byte-func 0)
name))
(make-comp-func-d :lambda-list (aref byte-func 0)))))
(setf (comp-func-name func) name
@@ -790,9 +802,9 @@ clashes."
(comp-func-command-modes func) (command-modes byte-func)
(comp-func-c-name func) c-name
(comp-func-lap func) lap
- (comp-func-frame-size func) (comp-byte-frame-size byte-func)
- (comp-func-speed func) (comp-spill-speed name)
- (comp-func-pure func) (comp-spill-decl-spec name 'pure))
+ (comp-func-frame-size func) (comp--byte-frame-size byte-func)
+ (comp-func-speed func) (comp--spill-speed name)
+ (comp-func-pure func) (comp--spill-decl-spec name 'pure))
;; Store the c-name to have it retrievable from
;; `comp-ctxt-top-level-forms'.
@@ -800,11 +812,11 @@ clashes."
(setf (byte-to-native-func-def-c-name top-l-form) c-name))
(unless name
(puthash byte-func func (comp-ctxt-byte-func-to-func-h comp-ctxt)))
- (comp-add-func-to-ctxt func)
+ (comp--add-func-to-ctxt func)
(comp-log (format "Function %s:\n" name) 1)
(comp-log lap 1 t))))
-(cl-defmethod comp-spill-lap-function ((filename string))
+(cl-defmethod comp--spill-lap-function ((filename string))
"Byte-compile FILENAME, spilling data from the byte compiler."
(byte-compile-file filename)
(when (or (null byte-native-qualities)
@@ -829,7 +841,7 @@ clashes."
collect
(if (and (byte-to-native-func-def-p form)
(eq -1
- (comp-spill-speed (byte-to-native-func-def-name form))))
+ (comp--spill-speed (byte-to-native-func-def-name form))))
(let ((byte-code (byte-to-native-func-def-byte-func form)))
(remhash byte-code byte-to-native-lambdas-h)
(make-byte-to-native-top-level
@@ -837,11 +849,11 @@ clashes."
',(byte-to-native-func-def-name form)
,byte-code
nil)
- :lexical (comp-lex-byte-func-p byte-code)))
+ :lexical (comp--lex-byte-func-p byte-code)))
form)))
- (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))
+ (maphash #'comp--intern-func-in-ctxt byte-to-native-lambdas-h))
-(defun comp-spill-lap (input)
+(defun comp--spill-lap (input)
"Byte-compile and spill the LAP representation for INPUT.
If INPUT is a symbol, it is the function-name to be compiled.
If INPUT is a string, it is the filename to be compiled."
@@ -849,7 +861,7 @@ If INPUT is a string, it is the filename to be compiled."
(byte-to-native-lambdas-h (make-hash-table :test #'eq))
(byte-to-native-top-level-forms ())
(byte-to-native-plist-environment ())
- (res (comp-spill-lap-function input)))
+ (res (comp--spill-lap-function input)))
(comp-cstr-ctxt-update-type-slots comp-ctxt)
res))
@@ -878,55 +890,55 @@ Points to the next slot to be filled.")
byte-switch byte-pushconditioncase)
"LAP end of basic blocks op codes.")
-(defun comp-lap-eob-p (inst)
+(defun comp--lap-eob-p (inst)
"Return t if INST closes the current basic blocks, nil otherwise."
(when (memq (car inst) comp-lap-eob-ops)
t))
-(defun comp-lap-fall-through-p (inst)
+(defun comp--lap-fall-through-p (inst)
"Return t if INST falls through, nil otherwise."
(when (not (memq (car inst) '(byte-goto byte-return)))
t))
-(defsubst comp-sp ()
+(defsubst comp--sp ()
"Current stack pointer."
(declare (gv-setter (lambda (val)
`(setf (comp-limplify-sp comp-pass) ,val))))
(comp-limplify-sp comp-pass))
-(defmacro comp-with-sp (sp &rest body)
+(defmacro comp--with-sp (sp &rest body)
"Execute BODY setting the stack pointer to SP.
Restore the original value afterwards."
(declare (debug (form body))
(indent defun))
(let ((sym (gensym)))
- `(let ((,sym (comp-sp)))
- (setf (comp-sp) ,sp)
+ `(let ((,sym (comp--sp)))
+ (setf (comp--sp) ,sp)
(progn ,@body)
- (setf (comp-sp) ,sym))))
+ (setf (comp--sp) ,sym))))
-(defsubst comp-slot-n (n)
+(defsubst comp--slot-n (n)
"Slot N into the meta-stack."
(comp-vec-aref (comp-limplify-frame comp-pass) n))
-(defsubst comp-slot ()
+(defsubst comp--slot ()
"Current slot into the meta-stack pointed by sp."
- (comp-slot-n (comp-sp)))
+ (comp--slot-n (comp--sp)))
-(defsubst comp-slot+1 ()
+(defsubst comp--slot+1 ()
"Slot into the meta-stack pointed by sp + 1."
- (comp-slot-n (1+ (comp-sp))))
+ (comp--slot-n (1+ (comp--sp))))
-(defsubst comp-label-to-addr (label)
+(defsubst comp--label-to-addr (label)
"Find the address of LABEL."
(or (gethash label (comp-limplify-label-to-addr comp-pass))
(signal 'native-ice (list "label not found" label))))
-(defsubst comp-mark-curr-bb-closed ()
+(defsubst comp--mark-curr-bb-closed ()
"Mark the current basic block as closed."
(setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t))
-(defun comp-bb-maybe-add (lap-addr &optional sp)
+(defun comp--bb-maybe-add (lap-addr &optional sp)
"If necessary create a pending basic block for LAP-ADDR with stack depth SP.
The basic block is returned regardless it was already declared or not."
(let ((bb (or (cl-loop ; See if the block was already limplified.
@@ -944,24 +956,24 @@ The basic block is returned regardless it was already
declared or not."
(signal 'native-ice (list "incoherent stack pointers"
sp (comp-block-lap-sp bb))))
bb)
- (car (push (make--comp-block-lap lap-addr sp (comp-new-block-sym))
+ (car (push (make--comp-block-lap lap-addr sp (comp--new-block-sym))
(comp-limplify-pending-blocks comp-pass))))))
-(defsubst comp-call (func &rest args)
+(defsubst comp--call (func &rest args)
"Emit a call for function FUNC with ARGS."
`(call ,func ,@args))
-(defun comp-callref (func nargs stack-off)
+(defun comp--callref (func nargs stack-off)
"Emit a call using narg abi for FUNC.
NARGS is the number of arguments.
STACK-OFF is the index of the first slot frame involved."
`(callref ,func ,@(cl-loop repeat nargs
for sp from stack-off
- collect (comp-slot-n sp))))
+ collect (comp--slot-n sp))))
-(cl-defun make-comp-mvar (&key slot (constant nil const-vld) type neg)
+(cl-defun make--comp-mvar (&key slot (constant nil const-vld) type neg)
"`comp-mvar' initializer."
- (let ((mvar (make--comp-mvar :slot slot)))
+ (let ((mvar (make--comp-mvar0 :slot slot)))
(when const-vld
(comp--add-const-to-relocs constant)
(setf (comp-cstr-imm mvar) constant))
@@ -971,49 +983,49 @@ STACK-OFF is the index of the first slot frame involved."
(setf (comp-mvar-neg mvar) t))
mvar))
-(defun comp-new-frame (size vsize &optional ssa)
+(defun comp--new-frame (size vsize &optional ssa)
"Return a clean frame of meta variables of size SIZE and VSIZE.
If SSA is non-nil, populate it with m-var in ssa form."
(cl-loop with v = (make-comp-vec :beg (- vsize) :end size)
for i from (- vsize) below size
for mvar = (if ssa
- (make-comp-ssa-mvar :slot i)
- (make-comp-mvar :slot i))
+ (make--comp--ssa-mvar :slot i)
+ (make--comp-mvar :slot i))
do (setf (comp-vec-aref v i) mvar)
finally return v))
-(defun comp-emit (insn)
+(defun comp--emit (insn)
"Emit INSN into basic block BB."
(let ((bb (comp-limplify-curr-block comp-pass)))
(cl-assert (not (comp-block-closed bb)))
(push insn (comp-block-insns bb))))
-(defun comp-emit-set-call (call)
+(defun comp--emit-set-call (call)
"Emit CALL assigning the result to the current slot frame.
If the callee function is known to have a return type, propagate it."
(cl-assert call)
- (comp-emit (list 'set (comp-slot) call)))
+ (comp--emit (list 'set (comp--slot) call)))
-(defun comp-copy-slot (src-n &optional dst-n)
+(defun comp--copy-slot (src-n &optional dst-n)
"Set slot number DST-N to slot number SRC-N as source.
If DST-N is specified, use it; otherwise assume it to be the current slot."
- (comp-with-sp (or dst-n (comp-sp))
- (let ((src-slot (comp-slot-n src-n)))
+ (comp--with-sp (or dst-n (comp--sp))
+ (let ((src-slot (comp--slot-n src-n)))
(cl-assert src-slot)
- (comp-emit `(set ,(comp-slot) ,src-slot)))))
+ (comp--emit `(set ,(comp--slot) ,src-slot)))))
-(defsubst comp-emit-annotation (str)
+(defsubst comp--emit-annotation (str)
"Emit annotation STR."
- (comp-emit `(comment ,str)))
+ (comp--emit `(comment ,str)))
-(defsubst comp-emit-setimm (val)
+(defsubst comp--emit-setimm (val)
"Set constant VAL to current slot."
(comp--add-const-to-relocs val)
;; Leave relocation index nil on purpose, will be fixed-up in final
;; by `comp-finalize-relocs'.
- (comp-emit `(setimm ,(comp-slot) ,val)))
+ (comp--emit `(setimm ,(comp--slot) ,val)))
-(defun comp-make-curr-block (block-name entry-sp &optional addr)
+(defun comp--make-curr-block (block-name entry-sp &optional addr)
"Create a basic block with BLOCK-NAME and set it as current block.
ENTRY-SP is the sp value when entering.
Add block to the current function and return it."
@@ -1025,104 +1037,104 @@ Add block to the current function and return it."
(puthash (comp-block-name bb) bb (comp-func-blocks comp-func))
bb))
-(defun comp-latch-make-fill (target)
+(defun comp--latch-make-fill (target)
"Create a latch pointing to TARGET and fill it.
Return the created latch."
- (let ((latch (make-comp-latch :name (comp-new-block-sym "latch")))
+ (let ((latch (make-comp-latch :name (comp--new-block-sym "latch")))
(curr-bb (comp-limplify-curr-block comp-pass)))
- ;; See `comp-make-curr-block'.
+ ;; See `comp--make-curr-block'.
(setf (comp-limplify-curr-block comp-pass) latch)
(when (< (comp-func-speed comp-func) 3)
;; At speed 3 the programmer is responsible to manually
;; place `comp-maybe-gc-or-quit'.
- (comp-emit '(call comp-maybe-gc-or-quit)))
- ;; See `comp-emit-uncond-jump'.
- (comp-emit `(jump ,(comp-block-name target)))
- (comp-mark-curr-bb-closed)
+ (comp--emit '(call comp-maybe-gc-or-quit)))
+ ;; See `comp--emit-uncond-jump'.
+ (comp--emit `(jump ,(comp-block-name target)))
+ (comp--mark-curr-bb-closed)
(puthash (comp-block-name latch) latch (comp-func-blocks comp-func))
(setf (comp-limplify-curr-block comp-pass) curr-bb)
latch))
-(defun comp-emit-uncond-jump (lap-label)
+(defun comp--emit-uncond-jump (lap-label)
"Emit an unconditional branch to LAP-LABEL."
(cl-destructuring-bind (label-num . stack-depth) lap-label
(when stack-depth
- (cl-assert (= (1- stack-depth) (comp-sp))))
- (let* ((target-addr (comp-label-to-addr label-num))
- (target (comp-bb-maybe-add target-addr
- (comp-sp)))
+ (cl-assert (= (1- stack-depth) (comp--sp))))
+ (let* ((target-addr (comp--label-to-addr label-num))
+ (target (comp--bb-maybe-add target-addr
+ (comp--sp)))
(latch (when (< target-addr (comp-limplify-pc comp-pass))
- (comp-latch-make-fill target)))
+ (comp--latch-make-fill target)))
(eff-target-name (comp-block-name (or latch target))))
- (comp-emit `(jump ,eff-target-name))
- (comp-mark-curr-bb-closed))))
+ (comp--emit `(jump ,eff-target-name))
+ (comp--mark-curr-bb-closed))))
-(defun comp-emit-cond-jump (a b target-offset lap-label negated)
+(defun comp--emit-cond-jump (a b target-offset lap-label negated)
"Emit a conditional jump to LAP-LABEL when A and B satisfy EQ.
TARGET-OFFSET is the positive offset on the SP when branching to the target
block.
If NEGATED is non null, negate the tested condition.
Return value is the fall-through block name."
(cl-destructuring-bind (label-num . label-sp) lap-label
- (let* ((bb (comp-block-name (comp-bb-maybe-add
+ (let* ((bb (comp-block-name (comp--bb-maybe-add
(1+ (comp-limplify-pc comp-pass))
- (comp-sp)))) ; Fall through block.
- (target-sp (+ target-offset (comp-sp)))
- (target-addr (comp-label-to-addr label-num))
- (target (comp-bb-maybe-add target-addr target-sp))
+ (comp--sp)))) ; Fall through block.
+ (target-sp (+ target-offset (comp--sp)))
+ (target-addr (comp--label-to-addr label-num))
+ (target (comp--bb-maybe-add target-addr target-sp))
(latch (when (< target-addr (comp-limplify-pc comp-pass))
- (comp-latch-make-fill target)))
+ (comp--latch-make-fill target)))
(eff-target-name (comp-block-name (or latch target))))
(when label-sp
- (cl-assert (= (1- label-sp) (+ target-offset (comp-sp)))))
- (comp-emit (if negated
+ (cl-assert (= (1- label-sp) (+ target-offset (comp--sp)))))
+ (comp--emit (if negated
(list 'cond-jump a b bb eff-target-name)
(list 'cond-jump a b eff-target-name bb)))
- (comp-mark-curr-bb-closed)
+ (comp--mark-curr-bb-closed)
bb)))
-(defun comp-emit-handler (lap-label handler-type)
+(defun comp--emit-handler (lap-label handler-type)
"Emit a nonlocal-exit handler to LAP-LABEL of type HANDLER-TYPE."
(cl-destructuring-bind (label-num . label-sp) lap-label
- (cl-assert (= (- label-sp 2) (comp-sp)))
+ (cl-assert (= (- label-sp 2) (comp--sp)))
(setf (comp-func-has-non-local comp-func) t)
- (let* ((guarded-bb (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
- (comp-sp)))
- (handler-bb (comp-bb-maybe-add (comp-label-to-addr label-num)
- (1+ (comp-sp))))
- (pop-bb (make--comp-block-lap nil (comp-sp) (comp-new-block-sym))))
- (comp-emit (list 'push-handler
+ (let* ((guarded-bb (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass))
+ (comp--sp)))
+ (handler-bb (comp--bb-maybe-add (comp--label-to-addr label-num)
+ (1+ (comp--sp))))
+ (pop-bb (make--comp-block-lap nil (comp--sp)
(comp--new-block-sym))))
+ (comp--emit (list 'push-handler
handler-type
- (comp-slot+1)
+ (comp--slot+1)
(comp-block-name pop-bb)
(comp-block-name guarded-bb)))
- (comp-mark-curr-bb-closed)
+ (comp--mark-curr-bb-closed)
;; Emit the basic block to pop the handler if we got the non local.
(puthash (comp-block-name pop-bb) pop-bb (comp-func-blocks comp-func))
(setf (comp-limplify-curr-block comp-pass) pop-bb)
- (comp-emit `(fetch-handler ,(comp-slot+1)))
- (comp-emit `(jump ,(comp-block-name handler-bb)))
- (comp-mark-curr-bb-closed))))
+ (comp--emit `(fetch-handler ,(comp--slot+1)))
+ (comp--emit `(jump ,(comp-block-name handler-bb)))
+ (comp--mark-curr-bb-closed))))
-(defun comp-limplify-listn (n)
+(defun comp--limplify-listn (n)
"Limplify list N."
- (comp-with-sp (+ (comp-sp) n -1)
- (comp-emit-set-call (comp-call 'cons
- (comp-slot)
- (make-comp-mvar :constant nil))))
- (cl-loop for sp from (+ (comp-sp) n -2) downto (comp-sp)
- do (comp-with-sp sp
- (comp-emit-set-call (comp-call 'cons
- (comp-slot)
- (comp-slot+1))))))
-
-(defun comp-new-block-sym (&optional postfix)
+ (comp--with-sp (+ (comp--sp) n -1)
+ (comp--emit-set-call (comp--call 'cons
+ (comp--slot)
+ (make--comp-mvar :constant nil))))
+ (cl-loop for sp from (+ (comp--sp) n -2) downto (comp--sp)
+ do (comp--with-sp sp
+ (comp--emit-set-call (comp--call 'cons
+ (comp--slot)
+ (comp--slot+1))))))
+
+(defun comp--new-block-sym (&optional postfix)
"Return a unique symbol postfixing POSTFIX naming the next new basic block."
(intern (format (if postfix "bb_%s_%s" "bb_%s")
(funcall (comp-func-block-cnt-gen comp-func))
postfix)))
-(defun comp-fill-label-h ()
+(defun comp--fill-label-h ()
"Fill label-to-addr hash table for the current function."
(setf (comp-limplify-label-to-addr comp-pass) (make-hash-table :test 'eql))
(cl-loop for insn in (comp-func-lap comp-func)
@@ -1131,7 +1143,7 @@ Return value is the fall-through block name."
(`(TAG ,label . ,_)
(puthash label addr (comp-limplify-label-to-addr
comp-pass))))))
-(defun comp-jump-table-optimizable (jmp-table)
+(defun comp--jump-table-optimizable (jmp-table)
"Return t if JMP-TABLE can be optimized out."
;; Identify LAP sequences like:
;; (byte-constant #s(hash-table test eq purecopy t data (created 126 deleted
126 changed 126)) . 24)
@@ -1143,13 +1155,13 @@ Return value is the fall-through block name."
(`(TAG ,target . ,_label-sp)
(= target (car targets)))))))
-(defun comp-emit-switch (var last-insn)
+(defun comp--emit-switch (var last-insn)
"Emit a Limple for a lap jump table given VAR and LAST-INSN."
;; FIXME this not efficient for big jump tables. We should have a second
;; strategy for this case.
(pcase last-insn
(`(setimm ,_ ,jmp-table)
- (unless (comp-jump-table-optimizable jmp-table)
+ (unless (comp--jump-table-optimizable jmp-table)
(cl-loop
for test being each hash-keys of jmp-table
using (hash-value target-label)
@@ -1157,27 +1169,27 @@ Return value is the fall-through block name."
with test-func = (hash-table-test jmp-table)
for n from 1
for last = (= n len)
- for m-test = (make-comp-mvar :constant test)
- for target-name = (comp-block-name (comp-bb-maybe-add
- (comp-label-to-addr target-label)
- (comp-sp)))
+ for m-test = (make--comp-mvar :constant test)
+ for target-name = (comp-block-name (comp--bb-maybe-add
+ (comp--label-to-addr target-label)
+ (comp--sp)))
for ff-bb = (if last
- (comp-bb-maybe-add (1+ (comp-limplify-pc comp-pass))
- (comp-sp))
+ (comp--bb-maybe-add (1+ (comp-limplify-pc comp-pass))
+ (comp--sp))
(make--comp-block-lap nil
- (comp-sp)
- (comp-new-block-sym)))
+ (comp--sp)
+ (comp--new-block-sym)))
for ff-bb-name = (comp-block-name ff-bb)
if (eq test-func 'eq)
- do (comp-emit (list 'cond-jump var m-test target-name ff-bb-name))
+ do (comp--emit (list 'cond-jump var m-test target-name ff-bb-name))
else
;; Store the result of the comparison into the scratch slot before
;; emitting the conditional jump.
- do (comp-emit (list 'set (make-comp-mvar :slot 'scratch)
- (comp-call test-func var m-test)))
- (comp-emit (list 'cond-jump
- (make-comp-mvar :slot 'scratch)
- (make-comp-mvar :constant nil)
+ do (comp--emit (list 'set (make--comp-mvar :slot 'scratch)
+ (comp--call test-func var m-test)))
+ (comp--emit (list 'cond-jump
+ (make--comp-mvar :slot 'scratch)
+ (make--comp-mvar :constant nil)
ff-bb-name target-name))
unless last
;; All fall through are artificially created here except the last one.
@@ -1192,7 +1204,7 @@ SUBR-NAME is the name of function."
(or (gethash subr-name comp-subr-arities-h)
(func-arity subr-name)))
-(defun comp-emit-set-call-subr (subr-name sp-delta)
+(defun comp--emit-set-call-subr (subr-name sp-delta)
"Emit a call for SUBR-NAME.
SP-DELTA is the stack adjustment."
(let* ((nargs (1+ (- sp-delta)))
@@ -1203,39 +1215,39 @@ SP-DELTA is the stack adjustment."
(signal 'native-ice (list "subr contains unevalled args" subr-name)))
(if (eq maxarg 'many)
;; callref case.
- (comp-emit-set-call (comp-callref subr-name nargs (comp-sp)))
+ (comp--emit-set-call (comp--callref subr-name nargs (comp--sp)))
;; Normal call.
(unless (and (>= maxarg nargs) (<= minarg nargs))
(signal 'native-ice
(list "incoherent stack adjustment" nargs maxarg minarg)))
(let* ((subr-name subr-name)
(slots (cl-loop for i from 0 below maxarg
- collect (comp-slot-n (+ i (comp-sp))))))
- (comp-emit-set-call (apply #'comp-call (cons subr-name slots)))))))
+ collect (comp--slot-n (+ i (comp--sp))))))
+ (comp--emit-set-call (apply #'comp--call (cons subr-name slots)))))))
(eval-when-compile
- (defun comp-op-to-fun (x)
+ (defun comp--op-to-fun (x)
"Given the LAP op strip \"byte-\" to have the subr name."
(intern (string-replace "byte-" "" x)))
- (defun comp-body-eff (body op-name sp-delta)
+ (defun comp--body-eff (body op-name sp-delta)
"Given the original BODY, compute the effective one.
When BODY is `auto', guess function name from the LAP byte-code
name. Otherwise expect lname fnname."
(pcase (car body)
('auto
- `((comp-emit-set-call-subr ',(comp-op-to-fun op-name) ,sp-delta)))
+ `((comp--emit-set-call-subr ',(comp--op-to-fun op-name) ,sp-delta)))
((pred symbolp)
- `((comp-emit-set-call-subr ',(car body) ,sp-delta)))
+ `((comp--emit-set-call-subr ',(car body) ,sp-delta)))
(_ body))))
-(defmacro comp-op-case (&rest cases)
+(defmacro comp--op-case (&rest cases)
"Expand CASES into the corresponding `pcase' expansion.
This is responsible for generating the proper stack adjustment, when known,
and the annotation emission."
(declare (debug (body))
(indent defun))
- (declare-function comp-body-eff nil (body op-name sp-delta))
+ (declare-function comp--body-eff nil (body op-name sp-delta))
`(pcase op
,@(cl-loop for (op . body) in cases
for sp-delta = (gethash op comp-op-stack-info)
@@ -1244,55 +1256,55 @@ and the annotation emission."
collect `(',op
;; Log all LAP ops except the TAG one.
;; ,(unless (eq op 'TAG)
- ;; `(comp-emit-annotation
+ ;; `(comp--emit-annotation
;; ,(concat "LAP op " op-name)))
;; Emit the stack adjustment if present.
,(when (and sp-delta (not (eq 0 sp-delta)))
- `(cl-incf (comp-sp) ,sp-delta))
- ,@(comp-body-eff body op-name sp-delta))
+ `(cl-incf (comp--sp) ,sp-delta))
+ ,@(comp--body-eff body op-name sp-delta))
else
collect `(',op (signal 'native-ice
(list "unsupported LAP op" ',op-name))))
(_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op))))))
-(defun comp-limplify-lap-inst (insn)
+(defun comp--limplify-lap-inst (insn)
"Limplify LAP instruction INSN pushing it in the proper basic block."
(let ((op (car insn))
(arg (if (consp (cdr insn))
(cadr insn)
(cdr insn))))
- (comp-op-case
+ (comp--op-case
(TAG
(cl-destructuring-bind (_TAG label-num . label-sp) insn
;; Paranoid?
(when label-sp
(cl-assert (= (1- label-sp) (comp-limplify-sp comp-pass))))
- (comp-emit-annotation (format "LAP TAG %d" label-num))))
+ (comp--emit-annotation (format "LAP TAG %d" label-num))))
(byte-stack-ref
- (comp-copy-slot (- (comp-sp) arg 1)))
+ (comp--copy-slot (- (comp--sp) arg 1)))
(byte-varref
- (comp-emit-set-call (comp-call 'symbol-value (make-comp-mvar
+ (comp--emit-set-call (comp--call 'symbol-value (make--comp-mvar
:constant arg))))
(byte-varset
- (comp-emit (comp-call 'set_internal
- (make-comp-mvar :constant arg)
- (comp-slot+1))))
+ (comp--emit (comp--call 'set_internal
+ (make--comp-mvar :constant arg)
+ (comp--slot+1))))
(byte-varbind ;; Verify
- (comp-emit (comp-call 'specbind
- (make-comp-mvar :constant arg)
- (comp-slot+1))))
+ (comp--emit (comp--call 'specbind
+ (make--comp-mvar :constant arg)
+ (comp--slot+1))))
(byte-call
- (cl-incf (comp-sp) (- arg))
- (comp-emit-set-call (comp-callref 'funcall (1+ arg) (comp-sp))))
+ (cl-incf (comp--sp) (- arg))
+ (comp--emit-set-call (comp--callref 'funcall (1+ arg) (comp--sp))))
(byte-unbind
- (comp-emit (comp-call 'helper_unbind_n
- (make-comp-mvar :constant arg))))
+ (comp--emit (comp--call 'helper_unbind_n
+ (make--comp-mvar :constant arg))))
(byte-pophandler
- (comp-emit '(pop-handler)))
+ (comp--emit '(pop-handler)))
(byte-pushconditioncase
- (comp-emit-handler (cddr insn) 'condition-case))
+ (comp--emit-handler (cddr insn) 'condition-case))
(byte-pushcatch
- (comp-emit-handler (cddr insn) 'catcher))
+ (comp--emit-handler (cddr insn) 'catcher))
(byte-nth auto)
(byte-symbolp auto)
(byte-consp auto)
@@ -1301,19 +1313,19 @@ and the annotation emission."
(byte-eq auto)
(byte-memq auto)
(byte-not
- (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp))
- (make-comp-mvar :constant nil))))
+ (comp--emit-set-call (comp--call 'eq (comp--slot-n (comp--sp))
+ (make--comp-mvar :constant nil))))
(byte-car auto)
(byte-cdr auto)
(byte-cons auto)
(byte-list1
- (comp-limplify-listn 1))
+ (comp--limplify-listn 1))
(byte-list2
- (comp-limplify-listn 2))
+ (comp--limplify-listn 2))
(byte-list3
- (comp-limplify-listn 3))
+ (comp--limplify-listn 3))
(byte-list4
- (comp-limplify-listn 4))
+ (comp--limplify-listn 4))
(byte-length auto)
(byte-aref auto)
(byte-aset auto)
@@ -1324,11 +1336,11 @@ and the annotation emission."
(byte-get auto)
(byte-substring auto)
(byte-concat2
- (comp-emit-set-call (comp-callref 'concat 2 (comp-sp))))
+ (comp--emit-set-call (comp--callref 'concat 2 (comp--sp))))
(byte-concat3
- (comp-emit-set-call (comp-callref 'concat 3 (comp-sp))))
+ (comp--emit-set-call (comp--callref 'concat 3 (comp--sp))))
(byte-concat4
- (comp-emit-set-call (comp-callref 'concat 4 (comp-sp))))
+ (comp--emit-set-call (comp--callref 'concat 4 (comp--sp))))
(byte-sub1 1-)
(byte-add1 1+)
(byte-eqlsign =)
@@ -1338,7 +1350,7 @@ and the annotation emission."
(byte-geq >=)
(byte-diff -)
(byte-negate
- (comp-emit-set-call (comp-call 'negate (comp-slot))))
+ (comp--emit-set-call (comp--call 'negate (comp--slot))))
(byte-plus +)
(byte-max auto)
(byte-min auto)
@@ -1353,9 +1365,9 @@ and the annotation emission."
(byte-preceding-char preceding-char)
(byte-current-column auto)
(byte-indent-to
- (comp-emit-set-call (comp-call 'indent-to
- (comp-slot)
- (make-comp-mvar :constant nil))))
+ (comp--emit-set-call (comp--call 'indent-to
+ (comp--slot)
+ (make--comp-mvar :constant nil))))
(byte-scan-buffer-OBSOLETE)
(byte-eolp auto)
(byte-eobp auto)
@@ -1364,7 +1376,7 @@ and the annotation emission."
(byte-current-buffer auto)
(byte-set-buffer auto)
(byte-save-current-buffer
- (comp-emit (comp-call 'record_unwind_current_buffer)))
+ (comp--emit (comp--call 'record_unwind_current_buffer)))
(byte-set-mark-OBSOLETE)
(byte-interactive-p-OBSOLETE)
(byte-forward-char auto)
@@ -1376,41 +1388,41 @@ and the annotation emission."
(byte-buffer-substring auto)
(byte-delete-region auto)
(byte-narrow-to-region
- (comp-emit-set-call (comp-call 'narrow-to-region
- (comp-slot)
- (comp-slot+1))))
+ (comp--emit-set-call (comp--call 'narrow-to-region
+ (comp--slot)
+ (comp--slot+1))))
(byte-widen
- (comp-emit-set-call (comp-call 'widen)))
+ (comp--emit-set-call (comp--call 'widen)))
(byte-end-of-line auto)
(byte-constant2) ; TODO
;; Branches.
(byte-goto
- (comp-emit-uncond-jump (cddr insn)))
+ (comp--emit-uncond-jump (cddr insn)))
(byte-goto-if-nil
- (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
+ (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0
(cddr insn) nil))
(byte-goto-if-not-nil
- (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 0
+ (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 0
(cddr insn) t))
(byte-goto-if-nil-else-pop
- (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
+ (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1
(cddr insn) nil))
(byte-goto-if-not-nil-else-pop
- (comp-emit-cond-jump (comp-slot+1) (make-comp-mvar :constant nil) 1
+ (comp--emit-cond-jump (comp--slot+1) (make--comp-mvar :constant nil) 1
(cddr insn) t))
(byte-return
- (comp-emit `(return ,(comp-slot+1))))
+ (comp--emit `(return ,(comp--slot+1))))
(byte-discard 'pass)
(byte-dup
- (comp-copy-slot (1- (comp-sp))))
+ (comp--copy-slot (1- (comp--sp))))
(byte-save-excursion
- (comp-emit (comp-call 'record_unwind_protect_excursion)))
+ (comp--emit (comp--call 'record_unwind_protect_excursion)))
(byte-save-window-excursion-OBSOLETE)
(byte-save-restriction
- (comp-emit (comp-call 'helper_save_restriction)))
+ (comp--emit (comp--call 'helper_save_restriction)))
(byte-catch) ;; Obsolete
(byte-unwind-protect
- (comp-emit (comp-call 'helper_unwind_protect (comp-slot+1))))
+ (comp--emit (comp--call 'helper_unwind_protect (comp--slot+1))))
(byte-condition-case) ;; Obsolete
(byte-temp-output-buffer-setup-OBSOLETE)
(byte-temp-output-buffer-show-OBSOLETE)
@@ -1437,61 +1449,61 @@ and the annotation emission."
(byte-numberp auto)
(byte-integerp auto)
(byte-listN
- (cl-incf (comp-sp) (- 1 arg))
- (comp-emit-set-call (comp-callref 'list arg (comp-sp))))
+ (cl-incf (comp--sp) (- 1 arg))
+ (comp--emit-set-call (comp--callref 'list arg (comp--sp))))
(byte-concatN
- (cl-incf (comp-sp) (- 1 arg))
- (comp-emit-set-call (comp-callref 'concat arg (comp-sp))))
+ (cl-incf (comp--sp) (- 1 arg))
+ (comp--emit-set-call (comp--callref 'concat arg (comp--sp))))
(byte-insertN
- (cl-incf (comp-sp) (- 1 arg))
- (comp-emit-set-call (comp-callref 'insert arg (comp-sp))))
+ (cl-incf (comp--sp) (- 1 arg))
+ (comp--emit-set-call (comp--callref 'insert arg (comp--sp))))
(byte-stack-set
- (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1)))
+ (comp--copy-slot (1+ (comp--sp)) (- (comp--sp) arg -1)))
(byte-stack-set2 (cl-assert nil)) ;; TODO
(byte-discardN
- (cl-incf (comp-sp) (- arg)))
+ (cl-incf (comp--sp) (- arg)))
(byte-switch
;; Assume to follow the emission of a setimm.
- ;; This is checked into comp-emit-switch.
- (comp-emit-switch (comp-slot+1)
+ ;; This is checked into comp--emit-switch.
+ (comp--emit-switch (comp--slot+1)
(cl-first (comp-block-insns
(comp-limplify-curr-block comp-pass)))))
(byte-constant
- (comp-emit-setimm arg))
+ (comp--emit-setimm arg))
(byte-discardN-preserve-tos
- (cl-incf (comp-sp) (- arg))
- (comp-copy-slot (+ arg (comp-sp)))))))
+ (cl-incf (comp--sp) (- arg))
+ (comp--copy-slot (+ arg (comp--sp)))))))
-(defun comp-emit-narg-prologue (minarg nonrest rest)
+(defun comp--emit-narg-prologue (minarg nonrest rest)
"Emit the prologue for a narg function."
(cl-loop for i below minarg
- do (comp-emit `(set-args-to-local ,(comp-slot-n i)))
- (comp-emit '(inc-args)))
+ do (comp--emit `(set-args-to-local ,(comp--slot-n i)))
+ (comp--emit '(inc-args)))
(cl-loop for i from minarg below nonrest
for bb = (intern (format "entry_%s" i))
for fallback = (intern (format "entry_fallback_%s" i))
- do (comp-emit `(cond-jump-narg-leq ,i ,fallback ,bb))
- (comp-make-curr-block bb (comp-sp))
- (comp-emit `(set-args-to-local ,(comp-slot-n i)))
- (comp-emit '(inc-args))
- finally (comp-emit '(jump entry_rest_args)))
+ do (comp--emit `(cond-jump-narg-leq ,i ,fallback ,bb))
+ (comp--make-curr-block bb (comp--sp))
+ (comp--emit `(set-args-to-local ,(comp--slot-n i)))
+ (comp--emit '(inc-args))
+ finally (comp--emit '(jump entry_rest_args)))
(when (/= minarg nonrest)
(cl-loop for i from minarg below nonrest
for bb = (intern (format "entry_fallback_%s" i))
for next-bb = (if (= (1+ i) nonrest)
'entry_rest_args
(intern (format "entry_fallback_%s" (1+ i))))
- do (comp-with-sp i
- (comp-make-curr-block bb (comp-sp))
- (comp-emit-setimm nil)
- (comp-emit `(jump ,next-bb)))))
- (comp-make-curr-block 'entry_rest_args (comp-sp))
- (comp-emit `(set-rest-args-to-local ,(comp-slot-n nonrest)))
- (setf (comp-sp) nonrest)
+ do (comp--with-sp i
+ (comp--make-curr-block bb (comp--sp))
+ (comp--emit-setimm nil)
+ (comp--emit `(jump ,next-bb)))))
+ (comp--make-curr-block 'entry_rest_args (comp--sp))
+ (comp--emit `(set-rest-args-to-local ,(comp--slot-n nonrest)))
+ (setf (comp--sp) nonrest)
(when (and (> nonrest 8) (null rest))
- (cl-decf (comp-sp))))
+ (cl-decf (comp--sp))))
-(defun comp-limplify-finalize-function (func)
+(defun comp--limplify-finalize-function (func)
"Reverse insns into all basic blocks of FUNC."
(cl-loop for bb being the hash-value in (comp-func-blocks func)
do (setf (comp-block-insns bb)
@@ -1499,49 +1511,49 @@ and the annotation emission."
(comp--log-func func 2)
func)
-(cl-defgeneric comp-prepare-args-for-top-level (function)
+(cl-defgeneric comp--prepare-args-for-top-level (function)
"Given FUNCTION, return the two arguments for comp--register-...")
-(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-l))
+(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-l))
"Lexically-scoped FUNCTION."
(let ((args (comp-func-l-args function)))
- (cons (make-comp-mvar :constant (comp-args-base-min args))
- (make-comp-mvar :constant (cond
+ (cons (make--comp-mvar :constant (comp-args-base-min args))
+ (make--comp-mvar :constant (cond
((comp-args-p args) (comp-args-max args))
((comp-nargs-rest args) 'many)
(t (comp-nargs-nonrest args)))))))
-(cl-defmethod comp-prepare-args-for-top-level ((function comp-func-d))
+(cl-defmethod comp--prepare-args-for-top-level ((function comp-func-d))
"Dynamically scoped FUNCTION."
- (cons (make-comp-mvar :constant (func-arity (comp-func-byte-func function)))
+ (cons (make--comp-mvar :constant (func-arity (comp-func-byte-func function)))
(let ((comp-curr-allocation-class 'd-default))
;; Lambda-lists must stay in the same relocation class of
;; the object referenced by code to respect uninterned
;; symbols.
- (make-comp-mvar :constant (comp-func-d-lambda-list function)))))
+ (make--comp-mvar :constant (comp-func-d-lambda-list function)))))
-(cl-defgeneric comp-emit-for-top-level (form for-late-load)
+(cl-defgeneric comp--emit-for-top-level (form for-late-load)
"Emit the Limple code for top level FORM.")
-(cl-defmethod comp-emit-for-top-level ((form byte-to-native-func-def)
+(cl-defmethod comp--emit-for-top-level ((form byte-to-native-func-def)
for-late-load)
(let* ((name (byte-to-native-func-def-name form))
(c-name (byte-to-native-func-def-c-name form))
(f (gethash c-name (comp-ctxt-funcs-h comp-ctxt)))
- (args (comp-prepare-args-for-top-level f)))
+ (args (comp--prepare-args-for-top-level f)))
(cl-assert (and name f))
- (comp-emit
- `(set ,(make-comp-mvar :slot 1)
- ,(comp-call (if for-late-load
+ (comp--emit
+ `(set ,(make--comp-mvar :slot 1)
+ ,(comp--call (if for-late-load
'comp--late-register-subr
'comp--register-subr)
- (make-comp-mvar :constant name)
- (make-comp-mvar :constant c-name)
+ (make--comp-mvar :constant name)
+ (make--comp-mvar :constant c-name)
(car args)
(cdr args)
(setf (comp-func-type f)
- (make-comp-mvar :constant nil))
- (make-comp-mvar
+ (make--comp-mvar :constant nil))
+ (make--comp-mvar
:constant
(list
(let* ((h (comp-ctxt-function-docs comp-ctxt))
@@ -1552,40 +1564,40 @@ and the annotation emission."
(comp-func-command-modes f)))
;; This is the compilation unit it-self passed as
;; parameter.
- (make-comp-mvar :slot 0))))))
+ (make--comp-mvar :slot 0))))))
-(cl-defmethod comp-emit-for-top-level ((form byte-to-native-top-level)
+(cl-defmethod comp--emit-for-top-level ((form byte-to-native-top-level)
for-late-load)
(unless for-late-load
- (comp-emit
- (comp-call 'eval
+ (comp--emit
+ (comp--call 'eval
(let ((comp-curr-allocation-class 'd-impure))
- (make-comp-mvar :constant
+ (make--comp-mvar :constant
(byte-to-native-top-level-form form)))
- (make-comp-mvar :constant
+ (make--comp-mvar :constant
(byte-to-native-top-level-lexical form))))))
-(defun comp-emit-lambda-for-top-level (func)
+(defun comp--emit-lambda-for-top-level (func)
"Emit the creation of subrs for lambda FUNC.
These are stored in the reloc data array."
- (let ((args (comp-prepare-args-for-top-level func)))
+ (let ((args (comp--prepare-args-for-top-level func)))
(let ((comp-curr-allocation-class 'd-impure))
(comp--add-const-to-relocs (comp-func-byte-func func)))
- (comp-emit
- (comp-call 'comp--register-lambda
+ (comp--emit
+ (comp--call 'comp--register-lambda
;; mvar to be fixed-up when containers are
;; finalized.
(or (gethash (comp-func-byte-func func)
(comp-ctxt-lambda-fixups-h comp-ctxt))
(puthash (comp-func-byte-func func)
- (make-comp-mvar :constant nil)
+ (make--comp-mvar :constant nil)
(comp-ctxt-lambda-fixups-h comp-ctxt)))
- (make-comp-mvar :constant (comp-func-c-name func))
+ (make--comp-mvar :constant (comp-func-c-name func))
(car args)
(cdr args)
(setf (comp-func-type func)
- (make-comp-mvar :constant nil))
- (make-comp-mvar
+ (make--comp-mvar :constant nil))
+ (make--comp-mvar
:constant
(list
(let* ((h (comp-ctxt-function-docs comp-ctxt))
@@ -1596,9 +1608,9 @@ These are stored in the reloc data array."
(comp-func-command-modes func)))
;; This is the compilation unit it-self passed as
;; parameter.
- (make-comp-mvar :slot 0)))))
+ (make--comp-mvar :slot 0)))))
-(defun comp-limplify-top-level (for-late-load)
+(defun comp--limplify-top-level (for-late-load)
"Create a Limple function to modify the global environment at load.
When FOR-LATE-LOAD is non-nil, the emitted function modifies only
function definition.
@@ -1628,22 +1640,22 @@ into the C code forwarding the compilation unit."
(comp-func func)
(comp-pass (make-comp-limplify
:curr-block (make--comp-block-lap -1 0 'top-level)
- :frame (comp-new-frame 1 0))))
- (comp-make-curr-block 'entry (comp-sp))
- (comp-emit-annotation (if for-late-load
+ :frame (comp--new-frame 1 0))))
+ (comp--make-curr-block 'entry (comp--sp))
+ (comp--emit-annotation (if for-late-load
"Late top level"
"Top level"))
;; Assign the compilation unit incoming as parameter to the slot frame 0.
- (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0))
+ (comp--emit `(set-par-to-local ,(comp--slot-n 0) 0))
(maphash (lambda (_ func)
- (comp-emit-lambda-for-top-level func))
+ (comp--emit-lambda-for-top-level func))
(comp-ctxt-byte-func-to-func-h comp-ctxt))
- (mapc (lambda (x) (comp-emit-for-top-level x for-late-load))
+ (mapc (lambda (x) (comp--emit-for-top-level x for-late-load))
(comp-ctxt-top-level-forms comp-ctxt))
- (comp-emit `(return ,(make-comp-mvar :slot 1)))
- (comp-limplify-finalize-function func)))
+ (comp--emit `(return ,(make--comp-mvar :slot 1)))
+ (comp--limplify-finalize-function func)))
-(defun comp-addr-to-bb-name (addr)
+(defun comp--addr-to-bb-name (addr)
"Search for a block starting at ADDR into pending or limplified blocks."
;; FIXME Actually we could have another hash for this.
(cl-flet ((pred (bb)
@@ -1655,7 +1667,7 @@ into the C code forwarding the compilation unit."
when (pred bb)
return (comp-block-name bb)))))
-(defun comp-limplify-block (bb)
+(defun comp--limplify-block (bb)
"Limplify basic-block BB and add it to the current function."
(setf (comp-limplify-curr-block comp-pass) bb
(comp-limplify-sp comp-pass) (comp-block-lap-sp bb)
@@ -1666,51 +1678,51 @@ into the C code forwarding the compilation unit."
(comp-func-lap comp-func))
for inst = (car inst-cell)
for next-inst = (car-safe (cdr inst-cell))
- do (comp-limplify-lap-inst inst)
+ do (comp--limplify-lap-inst inst)
(cl-incf (comp-limplify-pc comp-pass))
- when (comp-lap-fall-through-p inst)
+ when (comp--lap-fall-through-p inst)
do (pcase next-inst
(`(TAG ,_label . ,label-sp)
(when label-sp
- (cl-assert (= (1- label-sp) (comp-sp))))
+ (cl-assert (= (1- label-sp) (comp--sp))))
(let* ((stack-depth (if label-sp
(1- label-sp)
- (comp-sp)))
- (next-bb (comp-block-name (comp-bb-maybe-add
+ (comp--sp)))
+ (next-bb (comp-block-name (comp--bb-maybe-add
(comp-limplify-pc comp-pass)
stack-depth))))
(unless (comp-block-closed bb)
- (comp-emit `(jump ,next-bb))))
+ (comp--emit `(jump ,next-bb))))
(cl-return)))
- until (comp-lap-eob-p inst)))
+ until (comp--lap-eob-p inst)))
-(defun comp-limplify-function (func)
+(defun comp--limplify-function (func)
"Limplify a single function FUNC."
(let* ((frame-size (comp-func-frame-size func))
(comp-func func)
(comp-pass (make-comp-limplify
- :frame (comp-new-frame frame-size 0))))
- (comp-fill-label-h)
+ :frame (comp--new-frame frame-size 0))))
+ (comp--fill-label-h)
;; Prologue
- (comp-make-curr-block 'entry (comp-sp))
- (comp-emit-annotation (concat "Lisp function: "
+ (comp--make-curr-block 'entry (comp--sp))
+ (comp--emit-annotation (concat "Lisp function: "
(symbol-name (comp-func-name func))))
;; Dynamic functions have parameters bound by the trampoline.
(when (comp-func-l-p func)
(let ((args (comp-func-l-args func)))
(if (comp-args-p args)
(cl-loop for i below (comp-args-max args)
- do (cl-incf (comp-sp))
- (comp-emit `(set-par-to-local ,(comp-slot) ,i)))
- (comp-emit-narg-prologue (comp-args-base-min args)
+ do (cl-incf (comp--sp))
+ (comp--emit `(set-par-to-local ,(comp--slot) ,i)))
+ (comp--emit-narg-prologue (comp-args-base-min args)
(comp-nargs-nonrest args)
(comp-nargs-rest args)))))
- (comp-emit '(jump bb_0))
+ (comp--emit '(jump bb_0))
;; Body
- (comp-bb-maybe-add 0 (comp-sp))
+ (comp--bb-maybe-add 0 (comp--sp))
(cl-loop for next-bb = (pop (comp-limplify-pending-blocks comp-pass))
while next-bb
- do (comp-limplify-block next-bb))
+ do (comp--limplify-block next-bb))
;; Sanity check against block duplication.
(cl-loop with addr-h = (make-hash-table)
for bb being the hash-value in (comp-func-blocks func)
@@ -1719,15 +1731,15 @@ into the C code forwarding the compilation unit."
when addr
do (cl-assert (null (gethash addr addr-h)))
(puthash addr t addr-h))
- (comp-limplify-finalize-function func)))
+ (comp--limplify-finalize-function func)))
-(defun comp-limplify (_)
+(defun comp--limplify (_)
"Compute LIMPLE IR for forms in `comp-ctxt'."
- (maphash (lambda (_ f) (comp-limplify-function f))
+ (maphash (lambda (_ f) (comp--limplify-function f))
(comp-ctxt-funcs-h comp-ctxt))
- (comp-add-func-to-ctxt (comp-limplify-top-level nil))
+ (comp--add-func-to-ctxt (comp--limplify-top-level nil))
(when (comp-ctxt-with-late-load comp-ctxt)
- (comp-add-func-to-ctxt (comp-limplify-top-level t))))
+ (comp--add-func-to-ctxt (comp--limplify-top-level t))))
;;; add-cstrs pass specific code.
@@ -1751,22 +1763,22 @@ into the C code forwarding the compilation unit."
;; type specifier.
-(defsubst comp-mvar-used-p (mvar)
+(defsubst comp--mvar-used-p (mvar)
"Non-nil when MVAR is used as lhs in the current function."
(declare (gv-setter (lambda (val)
`(puthash ,mvar ,val comp-pass))))
(gethash mvar comp-pass))
-(defun comp-collect-mvars (form)
+(defun comp--collect-mvars (form)
"Add rhs m-var present in FORM into `comp-pass'."
(cl-loop for x in form
if (consp x)
- do (comp-collect-mvars x)
+ do (comp--collect-mvars x)
else
when (comp-mvar-p x)
- do (setf (comp-mvar-used-p x) t)))
+ do (setf (comp--mvar-used-p x) t)))
-(defun comp-collect-rhs ()
+(defun comp--collect-rhs ()
"Collect all lhs mvars into `comp-pass'."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
@@ -1774,11 +1786,11 @@ into the C code forwarding the compilation unit."
for insn in (comp-block-insns b)
for (op . args) = insn
if (comp--assign-op-p op)
- do (comp-collect-mvars (cdr args))
+ do (comp--collect-mvars (cdr args))
else
- do (comp-collect-mvars args))))
+ do (comp--collect-mvars args))))
-(defun comp-negate-arithm-cmp-fun (function)
+(defun comp--negate-arithm-cmp-fun (function)
"Negate FUNCTION.
Return nil if we don't want to emit constraints for its negation."
(cl-ecase function
@@ -1788,7 +1800,7 @@ Return nil if we don't want to emit constraints for its
negation."
(>= '<)
(<= '>)))
-(defun comp-reverse-arithm-fun (function)
+(defun comp--reverse-arithm-fun (function)
"Reverse FUNCTION."
(cl-case function
(= '=)
@@ -1798,7 +1810,7 @@ Return nil if we don't want to emit constraints for its
negation."
(<= '>=)
(t function)))
-(defun comp-emit-assume (kind lhs rhs bb negated)
+(defun comp--emit-assume (kind lhs rhs bb negated)
"Emit an assume of kind KIND for mvar LHS being RHS.
When NEGATED is non-nil, the assumption is negated.
The assume is emitted at the beginning of the block BB."
@@ -1808,41 +1820,41 @@ The assume is emitted at the beginning of the block BB."
((or 'and 'and-nhc)
(if (comp-mvar-p rhs)
(let ((tmp-mvar (if negated
- (make-comp-mvar :slot (comp-mvar-slot rhs))
+ (make--comp-mvar :slot (comp-mvar-slot rhs))
rhs)))
- (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (push `(assume ,(make--comp-mvar :slot lhs-slot)
(,kind ,lhs ,tmp-mvar))
(comp-block-insns bb))
(if negated
(push `(assume ,tmp-mvar (not ,rhs))
(comp-block-insns bb))))
;; If is only a constraint we can negate it directly.
- (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (push `(assume ,(make--comp-mvar :slot lhs-slot)
(,kind ,lhs ,(if negated
(comp-cstr-negation-make rhs)
rhs)))
(comp-block-insns bb))))
((pred comp--arithm-cmp-fun-p)
(when-let ((kind (if negated
- (comp-negate-arithm-cmp-fun kind)
+ (comp--negate-arithm-cmp-fun kind)
kind)))
- (push `(assume ,(make-comp-mvar :slot lhs-slot)
+ (push `(assume ,(make--comp-mvar :slot lhs-slot)
(,kind ,lhs
,(if-let* ((vld (comp-cstr-imm-vld-p rhs))
(val (comp-cstr-imm rhs))
(ok (and (integerp val)
(not (memq kind '(= !=))))))
val
- (make-comp-mvar :slot (comp-mvar-slot
rhs)))))
+ (make--comp-mvar :slot (comp-mvar-slot
rhs)))))
(comp-block-insns bb))))
(_ (cl-assert nil)))
(setf (comp-func-ssa-status comp-func) 'dirty)))
-(defun comp-maybe-add-vmvar (op cmp-res insns-seq)
+(defun comp--maybe-add-vmvar (op cmp-res insns-seq)
"If CMP-RES is clobbering OP emit a new constrained mvar and return it.
Return OP otherwise."
(if-let ((match (eql (comp-mvar-slot op) (comp-mvar-slot cmp-res)))
- (new-mvar (make-comp-mvar
+ (new-mvar (make--comp-mvar
:slot
(- (cl-incf (comp-func-vframe-size comp-func))))))
(progn
@@ -1850,7 +1862,7 @@ Return OP otherwise."
new-mvar)
op))
-(defun comp-add-new-block-between (bb-symbol bb-a bb-b)
+(defun comp--add-new-block-between (bb-symbol bb-a bb-b)
"Create a new basic-block named BB-SYMBOL and add it between BB-A and BB-B."
(cl-loop
with new-bb = (make-comp-block-cstr :name bb-symbol
@@ -1873,7 +1885,7 @@ Return OP otherwise."
finally (cl-assert nil)))
;; Cheap substitute to a copy propagation pass...
-(defun comp-cond-cstrs-target-mvar (mvar exit-insn bb)
+(defun comp--cond-cstrs-target-mvar (mvar exit-insn bb)
"Given MVAR, search in BB the original mvar MVAR got assigned from.
Keep on searching till EXIT-INSN is encountered."
(cl-flet ((targetp (x)
@@ -1890,7 +1902,7 @@ Keep on searching till EXIT-INSN is encountered."
(setf res rhs)))
finally (cl-assert nil))))
-(defun comp-add-cond-cstrs-target-block (curr-bb target-bb-sym)
+(defun comp--add-cond-cstrs-target-block (curr-bb target-bb-sym)
"Return the appropriate basic block to add constraint assumptions into.
CURR-BB is the current basic block.
TARGET-BB-SYM is the symbol name of the target block."
@@ -1910,10 +1922,10 @@ TARGET-BB-SYM is the symbol name of the target block."
until (null (gethash new-name (comp-func-blocks comp-func)))
finally
;; Add it.
- (cl-return (comp-add-new-block-between new-name curr-bb target-bb))))))
+ (cl-return (comp--add-new-block-between new-name curr-bb target-bb))))))
-(defun comp-add-cond-cstrs-simple ()
- "`comp-add-cstrs' worker function for each selected function."
+(defun comp--add-cond-cstrs-simple ()
+ "`comp--add-cstrs' worker function for each selected function."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
do
@@ -1929,26 +1941,26 @@ TARGET-BB-SYM is the symbol name of the target block."
for branch-target-cell on blocks
for branch-target = (car branch-target-cell)
for negated in '(nil t)
- when (comp-mvar-used-p tmp-mvar)
+ when (comp--mvar-used-p tmp-mvar)
do
- (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (let ((block-target (comp--add-cond-cstrs-target-block b
branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target))
- (comp-emit-assume 'and tmp-mvar obj2 block-target negated))
+ (comp--emit-assume 'and tmp-mvar obj2 block-target negated))
finally (cl-return-from in-the-basic-block)))
(`((cond-jump ,obj1 ,obj2 . ,blocks))
(cl-loop
for branch-target-cell on blocks
for branch-target = (car branch-target-cell)
for negated in '(nil t)
- when (comp-mvar-used-p obj1)
+ when (comp--mvar-used-p obj1)
do
- (let ((block-target (comp-add-cond-cstrs-target-block b branch-target)))
+ (let ((block-target (comp--add-cond-cstrs-target-block b
branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target))
- (comp-emit-assume 'and obj1 obj2 block-target negated))
+ (comp--emit-assume 'and obj1 obj2 block-target negated))
finally (cl-return-from in-the-basic-block)))))))
-(defun comp-add-cond-cstrs ()
- "`comp-add-cstrs' worker function for each selected function."
+(defun comp--add-cond-cstrs ()
+ "`comp--add-cstrs' worker function for each selected function."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
do
@@ -1967,13 +1979,13 @@ TARGET-BB-SYM is the symbol name of the target block."
(set ,(and (pred comp-mvar-p) mvar-3)
(call memq ,(and (pred comp-mvar-p) mvar-1) ,(and (pred
comp-mvar-p) mvar-2)))
(cond-jump ,(and (pred comp-mvar-p) mvar-3) ,(pred comp-mvar-p) ,bb1
,bb2))
- (comp-emit-assume 'and mvar-tested
- (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag))
- (comp-add-cond-cstrs-target-block b bb2)
+ (comp--emit-assume 'and mvar-tested
+ (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
+ (comp--add-cond-cstrs-target-block b bb2)
nil)
- (comp-emit-assume 'and mvar-tested
- (make-comp-mvar :type (comp-cstr-cl-tag mvar-tag))
- (comp-add-cond-cstrs-target-block b bb1)
+ (comp--emit-assume 'and mvar-tested
+ (make--comp-mvar :type (comp-cstr-cl-tag mvar-tag))
+ (comp--add-cond-cstrs-target-block b bb1)
t))
(`((set ,(and (pred comp-mvar-p) cmp-res)
(,(pred comp--call-op-p)
@@ -1984,8 +1996,8 @@ TARGET-BB-SYM is the symbol name of the target block."
;; (comment ,_comment-str)
(cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
(cl-loop
- with target-mvar1 = (comp-cond-cstrs-target-mvar op1 (car insns-seq) b)
- with target-mvar2 = (comp-cond-cstrs-target-mvar op2 (car insns-seq) b)
+ with target-mvar1 = (comp--cond-cstrs-target-mvar op1 (car insns-seq)
b)
+ with target-mvar2 = (comp--cond-cstrs-target-mvar op2 (car insns-seq)
b)
for branch-target-cell on blocks
for branch-target = (car branch-target-cell)
for negated in '(t nil)
@@ -1994,19 +2006,19 @@ TARGET-BB-SYM is the symbol name of the target block."
(eql 'and-nhc)
(eq 'and)
(t fun))
- when (or (comp-mvar-used-p target-mvar1)
- (comp-mvar-used-p target-mvar2))
+ when (or (comp--mvar-used-p target-mvar1)
+ (comp--mvar-used-p target-mvar2))
do
- (let ((block-target (comp-add-cond-cstrs-target-block b
branch-target)))
+ (let ((block-target (comp--add-cond-cstrs-target-block b
branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target))
- (when (comp-mvar-used-p target-mvar1)
- (comp-emit-assume kind target-mvar1
- (comp-maybe-add-vmvar op2 cmp-res prev-insns-seq)
+ (when (comp--mvar-used-p target-mvar1)
+ (comp--emit-assume kind target-mvar1
+ (comp--maybe-add-vmvar op2 cmp-res
prev-insns-seq)
block-target negated))
- (when (comp-mvar-used-p target-mvar2)
- (comp-emit-assume (comp-reverse-arithm-fun kind)
+ (when (comp--mvar-used-p target-mvar2)
+ (comp--emit-assume (comp--reverse-arithm-fun kind)
target-mvar2
- (comp-maybe-add-vmvar op1 cmp-res prev-insns-seq)
+ (comp--maybe-add-vmvar op1 cmp-res
prev-insns-seq)
block-target negated)))
finally (cl-return-from in-the-basic-block)))
(`((set ,(and (pred comp-mvar-p) cmp-res)
@@ -2016,16 +2028,16 @@ TARGET-BB-SYM is the symbol name of the target block."
;; (comment ,_comment-str)
(cond-jump ,cmp-res ,(pred comp-mvar-p) . ,blocks))
(cl-loop
- with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b)
+ with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b)
with cstr = (comp--pred-to-cstr fun)
for branch-target-cell on blocks
for branch-target = (car branch-target-cell)
for negated in '(t nil)
- when (comp-mvar-used-p target-mvar)
+ when (comp--mvar-used-p target-mvar)
do
- (let ((block-target (comp-add-cond-cstrs-target-block b
branch-target)))
+ (let ((block-target (comp--add-cond-cstrs-target-block b
branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target))
- (comp-emit-assume 'and target-mvar cstr block-target negated))
+ (comp--emit-assume 'and target-mvar cstr block-target negated))
finally (cl-return-from in-the-basic-block)))
;; Match predicate on the negated branch (unless).
(`((set ,(and (pred comp-mvar-p) cmp-res)
@@ -2035,20 +2047,20 @@ TARGET-BB-SYM is the symbol name of the target block."
(set ,neg-cmp-res (call eq ,cmp-res ,(pred comp-cstr-null-p)))
(cond-jump ,neg-cmp-res ,(pred comp-mvar-p) . ,blocks))
(cl-loop
- with target-mvar = (comp-cond-cstrs-target-mvar op (car insns-seq) b)
+ with target-mvar = (comp--cond-cstrs-target-mvar op (car insns-seq) b)
with cstr = (comp--pred-to-cstr fun)
for branch-target-cell on blocks
for branch-target = (car branch-target-cell)
for negated in '(nil t)
- when (comp-mvar-used-p target-mvar)
+ when (comp--mvar-used-p target-mvar)
do
- (let ((block-target (comp-add-cond-cstrs-target-block b
branch-target)))
+ (let ((block-target (comp--add-cond-cstrs-target-block b
branch-target)))
(setf (car branch-target-cell) (comp-block-name block-target))
- (comp-emit-assume 'and target-mvar cstr block-target negated))
+ (comp--emit-assume 'and target-mvar cstr block-target negated))
finally (cl-return-from in-the-basic-block))))
(setf prev-insns-seq insns-seq))))
-(defsubst comp-insert-insn (insn insn-cell)
+(defsubst comp--insert-insn (insn insn-cell)
"Insert INSN as second insn of INSN-CELL."
(let ((next-cell (cdr insn-cell))
(new-cell `(,insn)))
@@ -2056,15 +2068,15 @@ TARGET-BB-SYM is the symbol name of the target block."
(cdr new-cell) next-cell
(comp-func-ssa-status comp-func) 'dirty)))
-(defun comp-emit-call-cstr (mvar call-cell cstr)
+(defun comp--emit-call-cstr (mvar call-cell cstr)
"Emit a constraint CSTR for MVAR after CALL-CELL."
- (let* ((new-mvar (make-comp-mvar :slot (comp-mvar-slot mvar)))
+ (let* ((new-mvar (make--comp-mvar :slot (comp-mvar-slot mvar)))
;; Have new-mvar as LHS *and* RHS to ensure monotonicity and
;; fwprop convergence!!
(insn `(assume ,new-mvar (and ,new-mvar ,mvar ,cstr))))
- (comp-insert-insn insn call-cell)))
+ (comp--insert-insn insn call-cell)))
-(defun comp-lambda-list-gen (lambda-list)
+(defun comp--lambda-list-gen (lambda-list)
"Return a generator to iterate over LAMBDA-LIST."
(lambda ()
(cl-case (car lambda-list)
@@ -2080,12 +2092,12 @@ TARGET-BB-SYM is the symbol name of the target block."
(car lambda-list)
(setf lambda-list (cdr lambda-list)))))))
-(defun comp-add-call-cstr ()
+(defun comp--add-call-cstr ()
"Add args assumptions for each function of which the type specifier is
known."
(cl-loop
for bb being each hash-value of (comp-func-blocks comp-func)
do
- (comp-loop-insn-in-block bb
+ (comp--loop-insn-in-block bb
(when-let ((match
(pcase insn
(`(set ,lhs (,(pred comp--call-op-p) ,f . ,args))
@@ -2096,10 +2108,10 @@ TARGET-BB-SYM is the symbol name of the target block."
(cl-values f cstr-f nil args))))))
(cl-multiple-value-bind (f cstr-f lhs args) match
(cl-loop
- with gen = (comp-lambda-list-gen (comp-cstr-f-args cstr-f))
+ with gen = (comp--lambda-list-gen (comp-cstr-f-args cstr-f))
for arg in args
for cstr = (funcall gen)
- for target = (comp-cond-cstrs-target-mvar arg insn bb)
+ for target = (comp--cond-cstrs-target-mvar arg insn bb)
unless (comp-cstr-p cstr)
do (signal 'native-ice
(list "Incoherent type specifier for function" f))
@@ -2110,9 +2122,9 @@ TARGET-BB-SYM is the symbol name of the target block."
(or (null lhs)
(not (eql (comp-mvar-slot lhs)
(comp-mvar-slot target)))))
- do (comp-emit-call-cstr target insn-cell cstr)))))))
+ do (comp--emit-call-cstr target insn-cell cstr)))))))
-(defun comp-add-cstrs (_)
+(defun comp--add-cstrs (_)
"Rewrite conditional branches adding appropriate `assume' insns.
This is introducing and placing `assume' insns in use by fwprop
to propagate conditional branch test information on target basic
@@ -2126,10 +2138,10 @@ blocks."
(not (comp-func-has-non-local f)))
(let ((comp-func f)
(comp-pass (make-hash-table :test #'eq)))
- (comp-collect-rhs)
- (comp-add-cond-cstrs-simple)
- (comp-add-cond-cstrs)
- (comp-add-call-cstr)
+ (comp--collect-rhs)
+ (comp--add-cond-cstrs-simple)
+ (comp--add-cond-cstrs)
+ (comp--add-call-cstr)
(comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -2141,7 +2153,7 @@ blocks."
;; avoid optimizing-out functions and preventing their redefinition
;; being effective.
-(defun comp-collect-calls (f)
+(defun comp--collect-calls (f)
"Return a list with all the functions called by F."
(cl-loop
with h = (make-hash-table :test #'eq)
@@ -2161,17 +2173,17 @@ blocks."
(comp-ctxt-funcs-h comp-ctxt)))
f))))
-(defun comp-pure-infer-func (f)
+(defun comp--pure-infer-func (f)
"If all functions called by F are pure then F is pure too."
(when (and (cl-every (lambda (x)
(or (comp--function-pure-p x)
(eq x (comp-func-name f))))
- (comp-collect-calls f))
+ (comp--collect-calls f))
(not (eq (comp-func-pure f) t)))
(comp-log (format "%s inferred to be pure" (comp-func-name f)))
(setf (comp-func-pure f) t)))
-(defun comp-ipa-pure (_)
+(defun comp--ipa-pure (_)
"Infer function purity."
(cl-loop
with pure-n = 0
@@ -2184,7 +2196,7 @@ blocks."
when (and (>= (comp-func-speed f) 3)
(comp-func-l-p f)
(not (comp-func-pure f)))
- do (comp-pure-infer-func f)
+ do (comp--pure-infer-func f)
count (comp-func-pure f))))
finally (comp-log (format "ipa-pure iterated %d times" n))))
@@ -2198,13 +2210,13 @@ blocks."
;; this form is called 'minimal SSA form'.
;; This pass should be run every time basic blocks or m-var are shuffled.
-(cl-defun make-comp-ssa-mvar (&rest rest &key _slot _constant _type)
- "Same as `make-comp-mvar' but set the `id' slot."
- (let ((mvar (apply #'make-comp-mvar rest)))
+(cl-defun make--comp--ssa-mvar (&rest rest &key _slot _constant _type)
+ "Same as `make--comp-mvar' but set the `id' slot."
+ (let ((mvar (apply #'make--comp-mvar rest)))
(setf (comp-mvar-id mvar) (sxhash-eq mvar))
mvar))
-(defun comp-clean-ssa (f)
+(defun comp--clean-ssa (f)
"Clean-up SSA for function F."
(setf (comp-func-edges-h f) (make-hash-table))
(cl-loop
@@ -2220,7 +2232,7 @@ blocks."
unless (eq 'phi (car insn))
collect insn))))
-(defun comp-compute-edges ()
+(defun comp--compute-edges ()
"Compute the basic block edges for the current function."
(cl-loop with blocks = (comp-func-blocks comp-func)
for bb being each hash-value of blocks
@@ -2256,7 +2268,7 @@ blocks."
(comp-block-in-edges (comp-edge-dst edge))))
(comp--log-edges comp-func)))
-(defun comp-collect-rev-post-order (basic-block)
+(defun comp--collect-rev-post-order (basic-block)
"Walk BASIC-BLOCK children and return their name in reversed post-order."
(let ((visited (make-hash-table))
(acc ()))
@@ -2271,7 +2283,7 @@ blocks."
(collect-rec basic-block)
acc)))
-(defun comp-compute-dominator-tree ()
+(defun comp--compute-dominator-tree ()
"Compute immediate dominators for each basic block in current function."
;; Originally based on: "A Simple, Fast Dominance Algorithm"
;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
@@ -2296,7 +2308,7 @@ blocks."
;; No point to go on if the only bb is 'entry'.
(bb0 (gethash 'bb_0 blocks)))
(cl-loop
- with rev-bb-list = (comp-collect-rev-post-order entry)
+ with rev-bb-list = (comp--collect-rev-post-order entry)
with changed = t
while changed
initially (progn
@@ -2323,7 +2335,7 @@ blocks."
new-idom)
changed t))))))
-(defun comp-compute-dominator-frontiers ()
+(defun comp--compute-dominator-frontiers ()
"Compute the dominator frontier for each basic block in `comp-func'."
;; Originally based on: "A Simple, Fast Dominance Algorithm"
;; Cooper, Keith D.; Harvey, Timothy J.; Kennedy, Ken (2001).
@@ -2338,7 +2350,7 @@ blocks."
(puthash b-name b (comp-block-df runner))
(setf runner (comp-block-idom runner))))))
-(defun comp-log-block-info ()
+(defun comp--log-block-info ()
"Log basic blocks info for the current function."
(maphash (lambda (name bb)
(let ((dom (comp-block-idom bb))
@@ -2351,7 +2363,7 @@ blocks."
3)))
(comp-func-blocks comp-func)))
-(defun comp-place-phis ()
+(defun comp--place-phis ()
"Place phi insns into the current function."
;; Originally based on: Static Single Assignment Book
;; Algorithm 3.1: Standard algorithm for inserting phi-functions
@@ -2392,7 +2404,7 @@ blocks."
(unless (cl-find y defs-v)
(push y w))))))))
-(defun comp-dom-tree-walker (bb pre-lambda post-lambda)
+(defun comp--dom-tree-walker (bb pre-lambda post-lambda)
"Dominator tree walker function starting from basic block BB.
PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non-nil."
(when pre-lambda
@@ -2402,18 +2414,18 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or
post-order if non-nil."
for child = (comp-edge-dst ed)
when (eq bb (comp-block-idom child))
;; Current block is the immediate dominator then recur.
- do (comp-dom-tree-walker child pre-lambda post-lambda)))
+ do (comp--dom-tree-walker child pre-lambda post-lambda)))
(when post-lambda
(funcall post-lambda bb)))
-(cl-defstruct (comp-ssa (:copier nil))
+(cl-defstruct (comp--ssa (:copier nil))
"Support structure used while SSA renaming."
- (frame (comp-new-frame (comp-func-frame-size comp-func)
+ (frame (comp--new-frame (comp-func-frame-size comp-func)
(comp-func-vframe-size comp-func) t)
:type comp-vec
:documentation "`comp-vec' of m-vars."))
-(defun comp-ssa-rename-insn (insn frame)
+(defun comp--ssa-rename-insn (insn frame)
(cl-loop
for slot-n from (- (comp-func-vframe-size comp-func))
below (comp-func-frame-size comp-func)
@@ -2424,7 +2436,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or
post-order if non-nil."
(eql slot-n (comp-mvar-slot x))))
(new-lvalue ()
;; If is an assignment make a new mvar and put it as l-value.
- (let ((mvar (make-comp-ssa-mvar :slot slot-n)))
+ (let ((mvar (make--comp--ssa-mvar :slot slot-n)))
(setf (comp-vec-aref frame slot-n) mvar
(cadr insn) mvar))))
(pcase insn
@@ -2434,7 +2446,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or
post-order if non-nil."
(new-lvalue))
(`(fetch-handler . ,_)
;; Clobber all no matter what!
- (setf (comp-vec-aref frame slot-n) (make-comp-ssa-mvar :slot slot-n)))
+ (setf (comp-vec-aref frame slot-n) (make--comp--ssa-mvar :slot
slot-n)))
(`(phi ,n)
(when (equal n slot-n)
(new-lvalue)))
@@ -2442,7 +2454,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or
post-order if non-nil."
(let ((mvar (comp-vec-aref frame slot-n)))
(setcdr insn (cl-nsubst-if mvar #'targetp (cdr insn)))))))))
-(defun comp-ssa-rename ()
+(defun comp--ssa-rename ()
"Entry point to rename into SSA within the current function."
(comp-log "Renaming\n" 2)
(let ((visited (make-hash-table)))
@@ -2450,7 +2462,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or
post-order if non-nil."
(unless (gethash bb visited)
(puthash bb t visited)
(cl-loop for insn in (comp-block-insns bb)
- do (comp-ssa-rename-insn insn in-frame))
+ do (comp--ssa-rename-insn insn in-frame))
(setf (comp-block-final-frame bb)
(copy-sequence in-frame))
(when-let ((out-edges (comp-block-out-edges bb)))
@@ -2461,11 +2473,11 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or
post-order if non-nil."
do (ssa-rename-rec child (comp-vec-copy in-frame)))))))
(ssa-rename-rec (gethash 'entry (comp-func-blocks comp-func))
- (comp-new-frame (comp-func-frame-size comp-func)
+ (comp--new-frame (comp-func-frame-size comp-func)
(comp-func-vframe-size comp-func)
t)))))
-(defun comp-finalize-phis ()
+(defun comp--finalize-phis ()
"Fixup r-values into phis in all basic blocks."
(cl-flet ((finalize-phi (args b)
;; Concatenate into args all incoming m-vars for this phi.
@@ -2482,7 +2494,7 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or
post-order if non-nil."
when (eq op 'phi)
do (finalize-phi args b)))))
-(defun comp-remove-unreachable-blocks ()
+(defun comp--remove-unreachable-blocks ()
"Remove unreachable basic blocks.
Return t when one or more block was removed, nil otherwise."
(cl-loop
@@ -2498,7 +2510,7 @@ Return t when one or more block was removed, nil
otherwise."
ret t)
finally return ret))
-(defun comp-ssa ()
+(defun comp--ssa ()
"Port all functions into minimal SSA form."
(maphash (lambda (_ f)
(let* ((comp-func f)
@@ -2506,15 +2518,15 @@ Return t when one or more block was removed, nil
otherwise."
(unless (eq ssa-status t)
(cl-loop
when (eq ssa-status 'dirty)
- do (comp-clean-ssa f)
- do (comp-compute-edges)
- (comp-compute-dominator-tree)
- until (null (comp-remove-unreachable-blocks)))
- (comp-compute-dominator-frontiers)
- (comp-log-block-info)
- (comp-place-phis)
- (comp-ssa-rename)
- (comp-finalize-phis)
+ do (comp--clean-ssa f)
+ do (comp--compute-edges)
+ (comp--compute-dominator-tree)
+ until (null (comp--remove-unreachable-blocks)))
+ (comp--compute-dominator-frontiers)
+ (comp--log-block-info)
+ (comp--place-phis)
+ (comp--ssa-rename)
+ (comp--finalize-phis)
(comp--log-func comp-func 3)
(setf (comp-func-ssa-status f) t))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -2526,12 +2538,12 @@ Return t when one or more block was removed, nil
otherwise."
;; This is also responsible for removing function calls to pure functions if
;; possible.
-(defconst comp-fwprop-max-insns-scan 4500
+(defconst comp--fwprop-max-insns-scan 4500
;; Chosen as ~ the greatest required value for full convergence
;; native compiling all Emacs code-base.
"Max number of scanned insn before giving-up.")
-(defun comp-copy-insn (insn)
+(defun comp--copy-insn (insn)
"Deep copy INSN."
;; Adapted from `copy-tree'.
(if (consp insn)
@@ -2539,16 +2551,16 @@ Return t when one or more block was removed, nil
otherwise."
(while (consp insn)
(let ((newcar (car insn)))
(if (or (consp (car insn)) (comp-mvar-p (car insn)))
- (setf newcar (comp-copy-insn (car insn))))
+ (setf newcar (comp--copy-insn (car insn))))
(push newcar result))
(setf insn (cdr insn)))
(nconc (nreverse result)
- (if (comp-mvar-p insn) (comp-copy-insn insn) insn)))
+ (if (comp-mvar-p insn) (comp--copy-insn insn) insn)))
(if (comp-mvar-p insn)
(copy-comp-mvar insn)
insn)))
-(defmacro comp-apply-in-env (func &rest args)
+(defmacro comp--apply-in-env (func &rest args)
"Apply FUNC to ARGS in the current compilation environment."
`(let ((env (cl-loop
for f being the hash-value in (comp-ctxt-funcs-h comp-ctxt)
@@ -2564,7 +2576,7 @@ Return t when one or more block was removed, nil
otherwise."
for (func-name . def) in env
do (setf (symbol-function func-name) def)))))
-(defun comp-fwprop-prologue ()
+(defun comp--fwprop-prologue ()
"Prologue for the propagate pass.
Here goes everything that can be done not iteratively (read once).
Forward propagate immediate involed in assignments." ; FIXME: Typo. Involved
or invoked?
@@ -2576,16 +2588,16 @@ Forward propagate immediate involed in assignments." ;
FIXME: Typo. Involved or
(`(setimm ,lval ,v)
(setf (comp-cstr-imm lval) v))))))
-(defun comp-function-foldable-p (f args)
+(defun comp--function-foldable-p (f args)
"Given function F called with ARGS, return non-nil when optimizable."
(and (comp--function-pure-p f)
(cl-every #'comp-cstr-imm-vld-p args)))
-(defun comp-function-call-maybe-fold (insn f args)
+(defun comp--function-call-maybe-fold (insn f args)
"Given INSN, when F is pure if all ARGS are known, remove the function call.
Return non-nil if the function is folded successfully."
(cl-flet ((rewrite-insn-as-setimm (insn value)
- ;; See `comp-emit-setimm'.
+ ;; See `comp--emit-setimm'.
(comp--add-const-to-relocs value)
(setf (car insn) 'setimm
(cddr insn) `(,value))))
@@ -2597,7 +2609,7 @@ Return non-nil if the function is folded successfully."
comp-symbol-values-optimizable)))
(rewrite-insn-as-setimm insn (symbol-value (comp-cstr-imm
(car args))))))
- ((comp-function-foldable-p f args)
+ ((comp--function-foldable-p f args)
(ignore-errors
;; No point to complain here in case of error because we
;; should do basic block pruning in order to be sure that this
@@ -2608,14 +2620,14 @@ Return non-nil if the function is folded successfully."
;; and know to be pure.
(comp-func-byte-func f-in-ctxt)
f))
- (value (comp-apply-in-env f (mapcar #'comp-cstr-imm args))))
+ (value (comp--apply-in-env f (mapcar #'comp-cstr-imm args))))
(rewrite-insn-as-setimm insn value)))))))
-(defun comp-fwprop-call (insn lval f args)
+(defun comp--fwprop-call (insn lval f args)
"Propagate on a call INSN into LVAL.
F is the function being called with arguments ARGS.
Fold the call in case."
- (unless (comp-function-call-maybe-fold insn f args)
+ (unless (comp--function-call-maybe-fold insn f args)
(when (and (eq 'funcall f)
(comp-cstr-imm-vld-p (car args)))
(setf f (comp-cstr-imm (car args))
@@ -2636,16 +2648,16 @@ Fold the call in case."
(comp-type-spec-to-cstr
(comp-cstr-imm (car args)))))))))
-(defun comp-fwprop-insn (insn)
+(defun comp--fwprop-insn (insn)
"Propagate within INSN."
(pcase insn
(`(set ,lval ,rval)
(pcase rval
(`(,(or 'call 'callref) ,f . ,args)
- (comp-fwprop-call insn lval f args))
+ (comp--fwprop-call insn lval f args))
(`(,(or 'direct-call 'direct-callref) ,f . ,args)
(let ((f (comp-func-name (gethash f (comp-ctxt-funcs-h comp-ctxt)))))
- (comp-fwprop-call insn lval f args)))
+ (comp--fwprop-call insn lval f args)))
(_
(comp-cstr-shallow-copy lval rval))))
(`(assume ,lval ,(and (pred comp-mvar-p) rval))
@@ -2690,7 +2702,7 @@ Fold the call in case."
(rvals (mapcar #'car rest)))
(apply prop-fn lval rvals)))))
-(defun comp-fwprop* ()
+(defun comp--fwprop* ()
"Propagate for set* and phi operands.
Return t if something was changed."
(cl-loop named outer
@@ -2702,17 +2714,17 @@ Return t if something was changed."
for insn in (comp-block-insns b)
for orig-insn = (unless modified
;; Save consing after 1st change.
- (comp-copy-insn insn))
+ (comp--copy-insn insn))
do
- (comp-fwprop-insn insn)
+ (comp--fwprop-insn insn)
(cl-incf i)
when (and (null modified) (not (equal insn orig-insn)))
do (setf modified t))
- when (> i comp-fwprop-max-insns-scan)
+ when (> i comp--fwprop-max-insns-scan)
do (cl-return-from outer nil)
finally return modified))
-(defun comp-rewrite-non-locals ()
+(defun comp--rewrite-non-locals ()
"Make explicit in LIMPLE non-local exits if identified."
(cl-loop
for bb being each hash-value of (comp-func-blocks comp-func)
@@ -2729,26 +2741,26 @@ Return t if something was changed."
(cdr insn-seq) '((unreachable))
(comp-func-ssa-status comp-func) 'dirty))))
-(defun comp-fwprop (_)
+(defun comp--fwprop (_)
"Forward propagate types and consts within the lattice."
- (comp-ssa)
- (comp-dead-code)
+ (comp--ssa)
+ (comp--dead-code)
(maphash (lambda (_ f)
(when (and (>= (comp-func-speed f) 2)
;; FIXME remove the following condition when tested.
(not (comp-func-has-non-local f)))
(let ((comp-func f))
- (comp-fwprop-prologue)
+ (comp--fwprop-prologue)
(cl-loop
for i from 1 to 100
- while (comp-fwprop*)
+ while (comp--fwprop*)
finally
(when (= i 100)
(display-warning
'comp
(format "fwprop pass jammed into %s?" (comp-func-name
f))))
(comp-log (format "Propagation run %d times\n" i) 2))
- (comp-rewrite-non-locals)
+ (comp--rewrite-non-locals)
(comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -2768,7 +2780,7 @@ Return t if something was changed."
;; the full compilation unit.
;; For this reason this is triggered only at native-comp-speed == 3.
-(defun comp-func-in-unit (func)
+(defun comp--func-in-unit (func)
"Given FUNC return the `comp-fun' definition in the current context.
FUNCTION can be a function-name or byte compiled function."
(if (symbolp func)
@@ -2776,11 +2788,11 @@ FUNCTION can be a function-name or byte compiled
function."
(cl-assert (byte-code-function-p func))
(gethash func (comp-ctxt-byte-func-to-func-h comp-ctxt))))
-(defun comp-call-optim-form-call (callee args)
+(defun comp--call-optim-form-call (callee args)
(cl-flet ((fill-args (args total)
;; Fill missing args to reach TOTAL
(append args (cl-loop repeat (- total (length args))
- collect (make-comp-mvar :constant nil)))))
+ collect (make--comp-mvar :constant nil)))))
(when (and callee
(or (symbolp callee)
(gethash callee (comp-ctxt-byte-func-to-func-h comp-ctxt)))
@@ -2798,7 +2810,7 @@ FUNCTION can be a function-name or byte compiled
function."
;; actually cheaper since it avoids the call to the
;; intermediate native trampoline (bug#67005).
(subrp (subrp f))
- (comp-func-callee (comp-func-in-unit callee)))
+ (comp-func-callee (comp--func-in-unit callee)))
(cond
((and subrp (not (subr-native-elisp-p f)))
;; Trampoline removal.
@@ -2833,30 +2845,30 @@ FUNCTION can be a function-name or byte compiled
function."
((comp--type-hint-p callee)
`(call ,callee ,@args)))))))
-(defun comp-call-optim-func ()
+(defun comp--call-optim-func ()
"Perform the trampoline call optimization for the current function."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
- do (comp-loop-insn-in-block b
+ do (comp--loop-insn-in-block b
(pcase insn
(`(set ,lval (callref funcall ,f . ,rest))
(when-let ((ok (comp-cstr-imm-vld-p f))
- (new-form (comp-call-optim-form-call
+ (new-form (comp--call-optim-form-call
(comp-cstr-imm f) rest)))
(setf insn `(set ,lval ,new-form))))
(`(callref funcall ,f . ,rest)
(when-let ((ok (comp-cstr-imm-vld-p f))
- (new-form (comp-call-optim-form-call
+ (new-form (comp--call-optim-form-call
(comp-cstr-imm f) rest)))
(setf insn new-form)))))))
-(defun comp-call-optim (_)
+(defun comp--call-optim (_)
"Try to optimize out funcall trampoline usage when possible."
(maphash (lambda (_ f)
(when (and (>= (comp-func-speed f) 2)
(comp-func-l-p f))
(let ((comp-func f))
- (comp-call-optim-func))))
+ (comp--call-optim-func))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -2867,16 +2879,16 @@ FUNCTION can be a function-name or byte compiled
function."
;;
;; This pass can be run as last optim.
-(defun comp-collect-mvar-ids (insn)
+(defun comp--collect-mvar-ids (insn)
"Collect the m-var unique identifiers into INSN."
(cl-loop for x in insn
if (consp x)
- append (comp-collect-mvar-ids x)
+ append (comp--collect-mvar-ids x)
else
when (comp-mvar-p x)
collect (comp-mvar-id x)))
-(defun comp-dead-assignments-func ()
+(defun comp--dead-assignments-func ()
"Clean-up dead assignments into current function.
Return the list of m-var ids nuked."
(let ((l-vals ())
@@ -2889,9 +2901,9 @@ Return the list of m-var ids nuked."
for (op arg0 . rest) = insn
if (comp--assign-op-p op)
do (push (comp-mvar-id arg0) l-vals)
- (setf r-vals (nconc (comp-collect-mvar-ids rest) r-vals))
+ (setf r-vals (nconc (comp--collect-mvar-ids rest) r-vals))
else
- do (setf r-vals (nconc (comp-collect-mvar-ids insn) r-vals))))
+ do (setf r-vals (nconc (comp--collect-mvar-ids insn) r-vals))))
;; Every l-value appearing that does not appear as r-value has no right to
;; exist and gets nuked.
(let ((nuke-list (cl-set-difference l-vals r-vals)))
@@ -2903,7 +2915,7 @@ Return the list of m-var ids nuked."
3)
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
- do (comp-loop-insn-in-block b
+ do (comp--loop-insn-in-block b
(cl-destructuring-bind (op &optional arg0 arg1 &rest rest) insn
(when (and (comp--assign-op-p op)
(memq (comp-mvar-id arg0) nuke-list))
@@ -2914,7 +2926,7 @@ Return the list of m-var ids nuked."
insn))))))))
nuke-list)))
-(defun comp-dead-code ()
+(defun comp--dead-code ()
"Dead code elimination."
(maphash (lambda (_ f)
(when (and (>= (comp-func-speed f) 2)
@@ -2923,7 +2935,7 @@ Return the list of m-var ids nuked."
(cl-loop
for comp-func = f
for i from 1
- while (comp-dead-assignments-func)
+ while (comp--dead-assignments-func)
finally (comp-log (format "dead code rm run %d times\n" i) 2)
(comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -2931,14 +2943,14 @@ Return the list of m-var ids nuked."
;;; Tail Call Optimization pass specific code.
-(defun comp-form-tco-call-seq (args)
+(defun comp--form-tco-call-seq (args)
"Generate a TCO sequence for ARGS."
`(,@(cl-loop for arg in args
for i from 0
- collect `(set ,(make-comp-mvar :slot i) ,arg))
+ collect `(set ,(make--comp-mvar :slot i) ,arg))
(jump bb_0)))
-(defun comp-tco-func ()
+(defun comp--tco-func ()
"Try to pattern match and perform TCO within the current function."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
@@ -2951,20 +2963,20 @@ Return the list of m-var ids nuked."
(return ,ret-val))
(when (and (string= func (comp-func-c-name comp-func))
(eq l-val ret-val))
- (let ((tco-seq (comp-form-tco-call-seq args)))
+ (let ((tco-seq (comp--form-tco-call-seq args)))
(setf (car insns-seq) (car tco-seq)
(cdr insns-seq) (cdr tco-seq)
(comp-func-ssa-status comp-func) 'dirty)
(cl-return-from in-the-basic-block))))))))
-(defun comp-tco (_)
+(defun comp--tco (_)
"Simple peephole pass performing self TCO."
(maphash (lambda (_ f)
(when (and (>= (comp-func-speed f) 3)
(comp-func-l-p f)
(not (comp-func-has-non-local f)))
(let ((comp-func f))
- (comp-tco-func)
+ (comp--tco-func)
(comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
@@ -2974,29 +2986,62 @@ Return the list of m-var ids nuked."
;; This must run after all SSA prop not to have the type hint
;; information overwritten.
-(defun comp-remove-type-hints-func ()
+(defun comp--remove-type-hints-func ()
"Remove type hints from the current function.
These are substituted with a normal `set' op."
(cl-loop
for b being each hash-value of (comp-func-blocks comp-func)
- do (comp-loop-insn-in-block b
+ do (comp--loop-insn-in-block b
(pcase insn
(`(set ,l-val (call ,(pred comp--type-hint-p) ,r-val))
(setf insn `(set ,l-val ,r-val)))))))
-(defun comp-remove-type-hints (_)
+(defun comp--remove-type-hints (_)
"Dead code elimination."
(maphash (lambda (_ f)
(when (>= (comp-func-speed f) 2)
(let ((comp-func f))
- (comp-remove-type-hints-func)
+ (comp--remove-type-hints-func)
(comp--log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
+;;; Function types pass specific code.
+
+(defun comp--compute-function-type (_ func)
+ "Compute type specifier for `comp-func' FUNC.
+Set it into the `type' slot."
+ (when (and (comp-func-l-p func)
+ (comp-mvar-p (comp-func-type func)))
+ (let* ((comp-func (make-comp-func))
+ (res-mvar (apply #'comp-cstr-union
+ (make-comp-cstr)
+ (cl-loop
+ with res = nil
+ for bb being the hash-value in (comp-func-blocks
+ func)
+ do (cl-loop
+ for insn in (comp-block-insns bb)
+ ;; Collect over every exit point the returned
+ ;; mvars and union results.
+ do (pcase insn
+ (`(return ,mvar)
+ (push mvar res))))
+ finally return res)))
+ (type `(function ,(comp--args-to-lambda-list (comp-func-l-args
func))
+ ,(comp-cstr-to-type-spec res-mvar))))
+ (comp--add-const-to-relocs type)
+ ;; Fix it up.
+ (setf (comp-cstr-imm (comp-func-type func)) type))))
+
+(defun comp--compute-function-types (_)
+ "Compute and store the type specifier for all functions."
+ (maphash #'comp--compute-function-type (comp-ctxt-funcs-h comp-ctxt)))
+
+
;;; Final pass specific code.
-(defun comp-args-to-lambda-list (args)
+(defun comp--args-to-lambda-list (args)
"Return a lambda list for ARGS."
(cl-loop
with res
@@ -3021,33 +3066,7 @@ These are substituted with a normal `set' op."
(push 't res))))
(cl-return (reverse res))))
-(defun comp-compute-function-type (_ func)
- "Compute type specifier for `comp-func' FUNC.
-Set it into the `type' slot."
- (when (and (comp-func-l-p func)
- (comp-mvar-p (comp-func-type func)))
- (let* ((comp-func (make-comp-func))
- (res-mvar (apply #'comp-cstr-union
- (make-comp-cstr)
- (cl-loop
- with res = nil
- for bb being the hash-value in (comp-func-blocks
- func)
- do (cl-loop
- for insn in (comp-block-insns bb)
- ;; Collect over every exit point the returned
- ;; mvars and union results.
- do (pcase insn
- (`(return ,mvar)
- (push mvar res))))
- finally return res)))
- (type `(function ,(comp-args-to-lambda-list (comp-func-l-args func))
- ,(comp-cstr-to-type-spec res-mvar))))
- (comp--add-const-to-relocs type)
- ;; Fix it up.
- (setf (comp-cstr-imm (comp-func-type func)) type))))
-
-(defun comp-finalize-container (cont)
+(defun comp--finalize-container (cont)
"Finalize data container CONT."
(setf (comp-data-container-l cont)
(cl-loop with h = (comp-data-container-idx cont)
@@ -3065,7 +3084,7 @@ Set it into the `type' slot."
'lambda-fixup
obj))))
-(defun comp-finalize-relocs ()
+(defun comp--finalize-relocs ()
"Finalize data containers for each relocation class.
Remove immediate duplicates within relocation classes.
Update all insn accordingly."
@@ -3081,7 +3100,7 @@ Update all insn accordingly."
(d-ephemeral (comp-ctxt-d-ephemeral comp-ctxt))
(d-ephemeral-idx (comp-data-container-idx d-ephemeral)))
;; We never want compiled lambdas ending up in pure space. A copy must
- ;; be already present in impure (see `comp-emit-lambda-for-top-level').
+ ;; be already present in impure (see `comp--emit-lambda-for-top-level').
(cl-loop for obj being each hash-keys of d-default-idx
when (gethash obj (comp-ctxt-lambda-fixups-h comp-ctxt))
do (cl-assert (gethash obj d-impure-idx))
@@ -3097,7 +3116,7 @@ Update all insn accordingly."
do (remhash obj d-ephemeral-idx))
;; Fix-up indexes in each relocation class and fill corresponding
;; reloc lists.
- (mapc #'comp-finalize-container (list d-default d-impure d-ephemeral))
+ (mapc #'comp--finalize-container (list d-default d-impure d-ephemeral))
;; Make a vector from the function documentation hash table.
(cl-loop with h = (comp-ctxt-function-docs comp-ctxt)
with v = (make-vector (hash-table-count h) nil)
@@ -3121,11 +3140,11 @@ Update all insn accordingly."
(comp-mvar-range mvar) (list (cons idx idx)))
(puthash idx t reverse-h))))
-(defun comp-compile-ctxt-to-file (name)
+(defun comp--compile-ctxt-to-file (name)
"Compile as native code the current context naming it NAME.
Prepare every function for final compilation and drive the C back-end."
(let ((dir (file-name-directory name)))
- (comp-finalize-relocs)
+ (comp--finalize-relocs)
(maphash (lambda (_ f)
(comp--log-func f 1))
(comp-ctxt-funcs-h comp-ctxt))
@@ -3133,12 +3152,12 @@ Prepare every function for final compilation and drive
the C back-end."
;; In case it's created in the meanwhile.
(ignore-error file-already-exists
(make-directory dir t)))
- (comp--compile-ctxt-to-file name)))
+ (comp--compile-ctxt-to-file0 name)))
-(defun comp-final1 ()
+(defun comp--final1 ()
(comp--init-ctxt)
(unwind-protect
- (comp-compile-ctxt-to-file (comp-ctxt-output comp-ctxt))
+ (comp--compile-ctxt-to-file (comp-ctxt-output comp-ctxt))
(comp--release-ctxt)))
(defvar comp-async-compilation nil
@@ -3147,17 +3166,16 @@ Prepare every function for final compilation and drive
the C back-end."
(defvar comp-running-batch-compilation nil
"Non-nil when compilation is driven by any `batch-*-compile' function.")
-(defun comp-final (_)
+(defun comp--final (_)
"Final pass driving the C back-end for code emission."
- (maphash #'comp-compute-function-type (comp-ctxt-funcs-h comp-ctxt))
(unless comp-dry-run
;; Always run the C side of the compilation as a sub-process
;; unless during bootstrap or async compilation (bug#45056). GCC
;; leaks memory but also interfere with the ability of Emacs to
;; detect when a sub-process completes (TODO understand why).
(if (or comp-running-batch-compilation comp-async-compilation)
- (comp-final1)
- ;; Call comp-final1 in a child process.
+ (comp--final1)
+ ;; Call comp--final1 in a child process.
(let* ((output (comp-ctxt-output comp-ctxt))
(print-escape-newlines t)
(print-length nil)
@@ -3179,7 +3197,7 @@ Prepare every function for final compilation and drive
the C back-end."
load-path ',load-path)
,native-comp-async-env-modifier-form
(message "Compiling %s..." ',output)
- (comp-final1)))
+ (comp--final1)))
(temp-file (make-temp-file
(concat "emacs-int-comp-"
(file-name-base output) "-")
@@ -3223,7 +3241,7 @@ Prepare every function for final compilation and drive
the C back-end."
;; Primitive function advice machinery
-(defun comp-make-lambda-list-from-subr (subr)
+(defun comp--make-lambda-list-from-subr (subr)
"Given SUBR return the equivalent lambda-list."
(pcase-let ((`(,min . ,max) (subr-arity subr))
(lambda-list '()))
@@ -3267,7 +3285,7 @@ Prepare every function for final compilation and drive
the C back-end."
;;;###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
+ (let* ((lambda-list (comp--make-lambda-list-from-subr
(symbol-function subr-name)))
;; The synthesized trampoline must expose the exact same ABI of
;; the primitive we are replacing in the function reloc table.
@@ -3311,6 +3329,7 @@ filename (including FILE)."
do (ignore-error file-error
(comp-delete-or-replace-file f))))))
+;; In use by comp.c.
(defun comp-delete-or-replace-file (oldfile &optional newfile)
"Replace OLDFILE with NEWFILE.
When NEWFILE is nil just delete OLDFILE.
@@ -3399,16 +3418,18 @@ the deferred compilation mechanism."
(if (and comp-async-compilation
(not (eq (car err) 'native-compiler-error)))
(progn
- (message (if err-val
- "%s: Error: %s %s"
- "%s: Error %s")
+ (message "%s: Error %s"
function-or-file
- (get (car err) 'error-message)
- (car-safe err-val))
+ (error-message-string err))
(kill-emacs -1))
;; Otherwise re-signal it adding the compilation input.
+ ;; FIXME: We can't just insert arbitrary info in the
+ ;; error-data part of an error: the handler may expect
+ ;; specific data at specific positions!
(signal (car err) (if (consp err-val)
(cons function-or-file err-val)
+ ;; FIXME: `err-val' is supposed to be
+ ;; a list, so it can only be nil here!
(list function-or-file err-val)))))))
(if (stringp function-or-file)
data
@@ -3492,7 +3513,8 @@ last directory in `native-comp-eln-load-path')."
else
collect (byte-compile-file file))))
-(defun comp-write-bytecode-file (eln-file)
+;; In use by elisp-mode.el
+(defun comp--write-bytecode-file (eln-file)
"After native compilation write the bytecode file for ELN-FILE.
Make sure that eln file is younger than byte-compiled one and
return the filename of this last.
@@ -3529,7 +3551,7 @@ variable \"NATIVE_DISABLED\" is set, only byte compile."
(car (last native-comp-eln-load-path)))
(byte-to-native-output-buffer-file nil)
(eln-file (car (batch-native-compile))))
- (comp-write-bytecode-file eln-file)
+ (comp--write-bytecode-file eln-file)
(setq command-line-args-left (cdr command-line-args-left)))))
(defun native-compile-prune-cache ()
diff --git a/lisp/emacs-lisp/compat.el b/lisp/emacs-lisp/compat.el
new file mode 100644
index 00000000000..f7037dc4101
--- /dev/null
+++ b/lisp/emacs-lisp/compat.el
@@ -0,0 +1,92 @@
+;;; compat.el --- Stub of the Compatibility Library -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2021-2024 Free Software Foundation, Inc.
+
+;; Author: \
+;; Philip Kaludercic <philipk@posteo.net>, \
+;; Daniel Mendler <mail@daniel-mendler.de>
+;; Maintainer: \
+;; Daniel Mendler <mail@daniel-mendler.de>, \
+;; Compat Development <~pkal/compat-devel@lists.sr.ht>,
+;; emacs-devel@gnu.org
+;; URL: https://github.com/emacs-compat/compat
+;; Keywords: lisp, maint
+
+;; This program 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.
+
+;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; The Compat package on ELPA provides forward-compatibility
+;; definitions for other packages. While mostly transparent, a
+;; minimal API is necessary whenever core definitions change calling
+;; conventions (e.g. `plist-get' can be invoked with a predicate from
+;; Emacs 29.1 onward). For core packages on ELPA to be able to take
+;; advantage of this functionality, the macros `compat-function' and
+;; `compat-call' have to be available in the core, usable even if
+;; users do not have the Compat package installed, which this file
+;; ensures.
+
+;; A basic introduction to Compat is given in the Info node `(elisp)
+;; Forwards Compatibility'. Further details on Compat are documented
+;; in the Info node `(compat) Top' (installed along with the Compat
+;; package) or read the same manual online:
+;; https://elpa.gnu.org/packages/doc/compat.html.
+
+;;; Code:
+
+(defmacro compat-function (fun)
+ "Return compatibility function symbol for FUN.
+This is a pseudo-compatibility stub for core packages on ELPA,
+that depend on the Compat package, whenever the user doesn't have
+the package installed on their current system."
+ `#',fun)
+
+(defmacro compat-call (fun &rest args)
+ "Call compatibility function or macro FUN with ARGS.
+This is a pseudo-compatibility stub for core packages on ELPA,
+that depend on the Compat package, whenever the user doesn't have
+the package installed on their current system."
+ (cons fun args))
+
+;;;; Clever trick to avoid installing Compat if not necessary
+
+;; The versioning scheme of the Compat package follows that of Emacs,
+;; to indicate the version of Emacs, that functionality is being
+;; provided for. For example, the Compat version number 29.2.3.9
+;; would attempt to provide compatibility definitions up to Emacs
+;; 29.2, while also designating that this is the third major release
+;; and ninth minor release of Compat, for the specific Emacs release.
+
+;; The package version of this file is specified programmatically,
+;; instead of giving a fixed version in the header of this file. This
+;; is done to ensure that the version of compat.el provided by Emacs
+;; always corresponds to the current version of Emacs. In addition to
+;; the major-minor version, a large "major release" makes sure that
+;; the built-in version of Compat is always preferred over an external
+;; installation. This means that if a package specifies a dependency
+;; on Compat which matches the current or an older version of Emacs
+;; that is being used, no additional dependencies have to be
+;; downloaded.
+;;
+;; Further details and background on this file can be found in the
+;; bug#66554 discussion.
+
+;;;###autoload (push (list 'compat
+;;;###autoload emacs-major-version
+;;;###autoload emacs-minor-version
+;;;###autoload 9999)
+;;;###autoload package--builtin-versions)
+
+(provide 'compat)
+;;; compat.el ends here
diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el
index 726f96a25f7..2423426dca0 100644
--- a/lisp/emacs-lisp/derived.el
+++ b/lisp/emacs-lisp/derived.el
@@ -365,137 +365,6 @@ which more-or-less shadow%s %s's corresponding table%s."
docstring))
-;;; OBSOLETE
-;; The functions below are only provided for backward compatibility with
-;; code byte-compiled with versions of derived.el prior to Emacs-21.
-
-(defsubst derived-mode-setup-function-name (mode)
- "Construct a setup-function name based on a MODE name."
- (declare (obsolete nil "28.1"))
- (intern (concat (symbol-name mode) "-setup")))
-
-
-;; Utility functions for defining a derived mode.
-
-;;;###autoload
-(defun derived-mode-init-mode-variables (mode)
- "Initialize variables for a new MODE.
-Right now, if they don't already exist, set up a blank keymap, an
-empty syntax table, and an empty abbrev table -- these will be merged
-the first time the mode is used."
-
- (if (boundp (derived-mode-map-name mode))
- t
- (eval `(defvar ,(derived-mode-map-name mode)
- (make-sparse-keymap)
- ,(format "Keymap for %s." mode)))
- (put (derived-mode-map-name mode) 'derived-mode-unmerged t))
-
- (if (boundp (derived-mode-syntax-table-name mode))
- t
- (eval `(defvar ,(derived-mode-syntax-table-name mode)
- ;; Make a syntax table which doesn't specify anything
- ;; for any char. Valid data will be merged in by
- ;; derived-mode-merge-syntax-tables.
- (make-char-table 'syntax-table nil)
- ,(format "Syntax table for %s." mode)))
- (put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t))
-
- (if (boundp (derived-mode-abbrev-table-name mode))
- t
- (eval `(defvar ,(derived-mode-abbrev-table-name mode)
- (progn
- (define-abbrev-table (derived-mode-abbrev-table-name ',mode) nil)
- (make-abbrev-table))
- ,(format "Abbrev table for %s." mode)))))
-
-;; Utility functions for running a derived mode.
-
-(defun derived-mode-set-keymap (mode)
- "Set the keymap of the new MODE, maybe merging with the parent."
- (let* ((map-name (derived-mode-map-name mode))
- (new-map (eval map-name))
- (old-map (current-local-map)))
- (and old-map
- (get map-name 'derived-mode-unmerged)
- (derived-mode-merge-keymaps old-map new-map))
- (put map-name 'derived-mode-unmerged nil)
- (use-local-map new-map)))
-
-(defun derived-mode-set-syntax-table (mode)
- "Set the syntax table of the new MODE, maybe merging with the parent."
- (let* ((table-name (derived-mode-syntax-table-name mode))
- (old-table (syntax-table))
- (new-table (eval table-name)))
- (if (get table-name 'derived-mode-unmerged)
- (derived-mode-merge-syntax-tables old-table new-table))
- (put table-name 'derived-mode-unmerged nil)
- (set-syntax-table new-table)))
-
-(defun derived-mode-set-abbrev-table (mode)
- "Set the abbrev table for MODE if it exists.
-Always merge its parent into it, since the merge is non-destructive."
- (let* ((table-name (derived-mode-abbrev-table-name mode))
- (old-table local-abbrev-table)
- (new-table (eval table-name)))
- (derived-mode-merge-abbrev-tables old-table new-table)
- (setq local-abbrev-table new-table)))
-
-(defun derived-mode-run-hooks (mode)
- "Run the mode hook for MODE."
- (let ((hooks-name (derived-mode-hook-name mode)))
- (if (boundp hooks-name)
- (run-hooks hooks-name))))
-
-;; Functions to merge maps and tables.
-
-(defun derived-mode-merge-keymaps (old new)
- "Merge an OLD keymap into a NEW one.
-The old keymap is set to be the last cdr of the new one, so that there will
-be automatic inheritance."
- ;; ?? Can this just use `set-keymap-parent'?
- (let ((tail new))
- ;; Scan the NEW map for prefix keys.
- (while (consp tail)
- (and (consp (car tail))
- (let* ((key (vector (car (car tail))))
- (subnew (lookup-key new key))
- (subold (lookup-key old key)))
- ;; If KEY is a prefix key in both OLD and NEW, merge them.
- (and (keymapp subnew) (keymapp subold)
- (derived-mode-merge-keymaps subold subnew))))
- (and (vectorp (car tail))
- ;; Search a vector of ASCII char bindings for prefix keys.
- (let ((i (1- (length (car tail)))))
- (while (>= i 0)
- (let* ((key (vector i))
- (subnew (lookup-key new key))
- (subold (lookup-key old key)))
- ;; If KEY is a prefix key in both OLD and NEW, merge them.
- (and (keymapp subnew) (keymapp subold)
- (derived-mode-merge-keymaps subold subnew)))
- (setq i (1- i)))))
- (setq tail (cdr tail))))
- (setcdr (nthcdr (1- (length new)) new) old))
-
-(defun derived-mode-merge-syntax-tables (old new)
- "Merge an OLD syntax table into a NEW one.
-Where the new table already has an entry, nothing is copied from the old one."
- (set-char-table-parent new old))
-
-;; Merge an old abbrev table into a new one.
-;; This function requires internal knowledge of how abbrev tables work,
-;; presuming that they are obarrays with the abbrev as the symbol, the
expansion
-;; as the value of the symbol, and the hook as the function definition.
-(defun derived-mode-merge-abbrev-tables (old new)
- (if old
- (mapatoms
- (lambda (symbol)
- (or (intern-soft (symbol-name symbol) new)
- (define-abbrev new (symbol-name symbol)
- (symbol-value symbol) (symbol-function symbol))))
- old)))
-
(provide 'derived)
;;; derived.el ends here
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index a876e6b5744..b7db2adde59 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -191,8 +191,6 @@ OBJ should be a call to BYTE-CODE generated by the byte
compiler."
(if (consp obj)
(setq bytes (car (cdr obj)) ;the byte code
constvec (car (cdr (cdr obj)))) ;constant vector
- ;; If it is lazy-loaded, load it now
- (fetch-bytecode obj)
(setq bytes (aref obj 1)
constvec (aref obj 2)))
(cl-assert (not (multibyte-string-p bytes)))
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index 05b23a86fc0..4fa05008dd8 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -132,7 +132,7 @@ it is disabled.")
(string-replace "'" "\\='" (format "%S" getter)))))
(let ((start (point)))
(insert argdoc)
- (when (fboundp 'fill-region)
+ (when (fboundp 'fill-region) ;Don't break bootstrap!
(fill-region start (point) 'left t))))
;; Finally, insert the keymap.
(when (and (boundp keymap-sym)
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index a8a51502503..4c7dbb4ef8c 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -481,7 +481,7 @@ just FUNCTION is printed."
(edebug--eval-defun #'eval-defun edebug-it)))
;;;###autoload
-(defalias 'edebug-defun 'edebug-eval-top-level-form)
+(defalias 'edebug-defun #'edebug-eval-top-level-form)
;;;###autoload
(defun edebug-eval-top-level-form ()
@@ -1729,7 +1729,7 @@ contains a circular object."
(defun edebug-match-form (cursor)
(list (edebug-form cursor)))
-(defalias 'edebug-match-place 'edebug-match-form)
+(defalias 'edebug-match-place #'edebug-match-form)
;; Currently identical to edebug-match-form.
;; This is for common lisp setf-style place arguments.
@@ -2277,12 +2277,7 @@ only be active while Edebug is. It checks
`debug-on-error' to see
whether it should call the debugger. When execution is resumed, the
error is signaled again."
(if (and (listp debug-on-error) (memq signal-name debug-on-error))
- (edebug 'error (cons signal-name signal-data)))
- ;; If we reach here without another non-local exit, then send signal again.
- ;; i.e. the signal is not continuable, yet.
- ;; Avoid infinite recursion.
- (let ((signal-hook-function nil))
- (signal signal-name signal-data)))
+ (edebug 'error (cons signal-name signal-data))))
;;; Entering Edebug
@@ -2326,6 +2321,12 @@ and run its entry function, and set up `edebug-before'
and
(debug-on-error (or debug-on-error edebug-on-error))
(debug-on-quit edebug-on-quit))
(unwind-protect
+ ;; FIXME: We could replace this `signal-hook-function' with
+ ;; a cleaner `handler-bind' but then we wouldn't be able to
+ ;; install it here (i.e. once and for all when entering
+ ;; an Edebugged function), but instead it would have to
+ ;; be installed into a modified `edebug-after' which wraps
+ ;; the `handler-bind' around its argument(s). :-(
(let ((signal-hook-function #'edebug-signal))
(setq edebug-execution-mode (or edebug-next-execution-mode
edebug-initial-mode
@@ -3348,7 +3349,7 @@ With prefix argument, make it a temporary breakpoint."
(message "%s" msg)))
-(defalias 'edebug-step-through-mode 'edebug-step-mode)
+(defalias 'edebug-step-through-mode #'edebug-step-mode)
(defun edebug-step-mode ()
"Proceed to next stop point."
@@ -3836,12 +3837,12 @@ be installed in `emacs-lisp-mode-map'.")
;; Global GUD bindings for all emacs-lisp-mode buffers.
(unless edebug-inhibit-emacs-lisp-mode-bindings
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode)
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode)
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode)
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where)
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" #'edebug-step-mode)
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" #'edebug-next-mode)
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" #'edebug-go-mode)
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" #'edebug-where)
;; The following isn't a GUD binding.
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" 'edebug-set-initial-mode))
+ (define-key emacs-lisp-mode-map "\C-x\C-a\C-m" #'edebug-set-initial-mode))
(defvar-keymap edebug-mode-map
:parent emacs-lisp-mode-map
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index df85a64baf3..fba69a36a97 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -387,9 +387,9 @@ contents of field NAME is matched against PAT, or they can
be of
,@(mapcar (lambda (field)
(pcase-exhaustive field
(`(,name ,pat)
- `(app (pcase--flip eieio-oref ',name) ,pat))
+ `(app (eieio-oref _ ',name) ,pat))
((pred symbolp)
- `(app (pcase--flip eieio-oref ',field) ,field))))
+ `(app (eieio-oref _ ',field) ,field))))
fields)))
;;; Simple generators, and query functions. None of these would do
diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el
index 912a7357ca7..24afd03fbe6 100644
--- a/lisp/emacs-lisp/eldoc.el
+++ b/lisp/emacs-lisp/eldoc.el
@@ -155,7 +155,7 @@ Remember to keep it a prime number to improve hash
performance.")
(defvar eldoc-message-commands
;; Don't define as `defconst' since it would then go to (read-only)
purespace.
- (make-vector eldoc-message-commands-table-size 0)
+ (obarray-make eldoc-message-commands-table-size)
"Commands after which it is appropriate to print in the echo area.
ElDoc does not try to print function arglists, etc., after just any command,
because some commands print their own messages in the echo area and these
@@ -191,7 +191,7 @@ It should receive the same arguments as `message'.")
When `eldoc-print-after-edit' is non-nil, ElDoc messages are only
printed after commands contained in this obarray."
- (let ((cmds (make-vector 31 0))
+ (let ((cmds (obarray-make 31))
(re (regexp-opt '("delete" "insert" "edit" "electric" "newline"))))
(mapatoms (lambda (s)
(and (commandp s)
diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el
index a8bc4bdd1e0..27c169cc657 100644
--- a/lisp/emacs-lisp/elint.el
+++ b/lisp/emacs-lisp/elint.el
@@ -266,6 +266,7 @@ This environment can be passed to `macroexpand'."
(insert-file-contents file)
(let ((buffer-file-name file)
(max-lisp-eval-depth (max 1000 max-lisp-eval-depth)))
+ (hack-local-variables)
(with-syntax-table emacs-lisp-mode-syntax-table
(mapc 'elint-top-form (elint-update-env)))))
(elint-set-mode-line)
diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el
index 63f547ebeb8..411602ef166 100644
--- a/lisp/emacs-lisp/find-func.el
+++ b/lisp/emacs-lisp/find-func.el
@@ -60,6 +60,7 @@
ine\\(?:-global\\)?-minor-mode\\|ine-compilation-mode\\|un-cvs-mode\\|\
foo\\|\\(?:[^icfgv]\\|g[^r]\\)\\(\\w\\|\\s_\\)+\\*?\\)\\|easy-mmode-define-[a-z-]+\\|easy-menu-define\\|\
cl-\\(?:defun\\|defmethod\\|defgeneric\\)\\|\
+transient-define-\\(?:prefix\\|suffix\\|infix\\|argument\\)\\|\
menu-bar-make-toggle\\|menu-bar-make-toggle-command\\)"
find-function-space-re
"\\('\\|(quote \\)?%s\\(\\s-\\|$\\|[()]\\)")
diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el
index c774296084e..ddbd6fdc017 100644
--- a/lisp/emacs-lisp/inline.el
+++ b/lisp/emacs-lisp/inline.el
@@ -80,7 +80,9 @@
(error "inline-const-p can only be used within define-inline"))
(defmacro inline-const-val (_exp)
- "Return the value of EXP."
+ "Return the value of EXP.
+During inlining, if the value of EXP is not yet known, this aborts the
+inlining and makes us revert to a non-inlined function call."
(declare (debug t))
(error "inline-const-val can only be used within define-inline"))
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el
index ca207ff548d..3475d944337 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/emacs-lisp/lisp-mode.el
@@ -1347,7 +1347,6 @@ Lisp function does not specify a special indentation."
(put 'condition-case 'lisp-indent-function 2)
(put 'handler-case 'lisp-indent-function 1) ;CL
(put 'unwind-protect 'lisp-indent-function 1)
-(put 'with-output-to-temp-buffer 'lisp-indent-function 1)
(put 'closure 'lisp-indent-function 2)
(defun indent-sexp (&optional endpos)
@@ -1420,14 +1419,15 @@ A prefix argument specifies pretty-printing."
;;;; Lisp paragraph filling commands.
-(defcustom emacs-lisp-docstring-fill-column 65
+(defcustom emacs-lisp-docstring-fill-column 72
"Value of `fill-column' to use when filling a docstring.
Any non-integer value means do not use a different value of
`fill-column' when filling docstrings."
:type '(choice (integer)
(const :tag "Use the current `fill-column'" t))
:safe (lambda (x) (or (eq x t) (integerp x)))
- :group 'lisp)
+ :group 'lisp
+ :version "30.1")
(defun lisp-fill-paragraph (&optional justify)
"Like \\[fill-paragraph], but handle Emacs Lisp comments and docstrings.
diff --git a/lisp/emacs-lisp/loaddefs-gen.el b/lisp/emacs-lisp/loaddefs-gen.el
index 5f152d3b509..581053f6304 100644
--- a/lisp/emacs-lisp/loaddefs-gen.el
+++ b/lisp/emacs-lisp/loaddefs-gen.el
@@ -183,7 +183,9 @@ expression, in which case we want to handle forms
differently."
(loaddefs-generate--shorten-autoload
`(autoload ,(nth 1 form) ,file ,doc ,interactive ,type))))
- ((and expansion (memq car '(progn prog1)))
+ ;; Look inside `progn', and `eval-and-compile', since these
+ ;; are often used in the expansion of things like `pcase-defmacro'.
+ ((and expansion (memq car '(progn prog1 eval-and-compile)))
(let ((end (memq :autoload-end form)))
(when end ;Cut-off anything after the :autoload-end marker.
(setq form (copy-sequence form))
@@ -199,8 +201,7 @@ expression, in which case we want to handle forms
differently."
define-globalized-minor-mode defun defmacro
easy-mmode-define-minor-mode define-minor-mode
define-inline cl-defun cl-defmacro cl-defgeneric
- cl-defstruct pcase-defmacro iter-defun cl-iter-defun
- transient-define-prefix))
+ cl-defstruct pcase-defmacro iter-defun cl-iter-defun))
(macrop car)
(setq expand (let ((load-true-file-name file)
(load-file-name file))
@@ -216,13 +217,17 @@ expression, in which case we want to handle forms
differently."
define-globalized-minor-mode
easy-mmode-define-minor-mode define-minor-mode
cl-defun defun* cl-defmacro defmacro*
- define-overloadable-function))
+ define-overloadable-function
+ transient-define-prefix transient-define-suffix
+ transient-define-infix transient-define-argument))
(let* ((macrop (memq car '(defmacro cl-defmacro defmacro*)))
(name (nth 1 form))
(args (pcase car
((or 'defun 'defmacro
'defun* 'defmacro* 'cl-defun 'cl-defmacro
- 'define-overloadable-function)
+ 'define-overloadable-function
+ 'transient-define-prefix 'transient-define-suffix
+ 'transient-define-infix 'transient-define-argument)
(nth 2 form))
('define-skeleton '(&optional str arg))
((or 'define-generic-mode 'define-derived-mode
@@ -244,7 +249,11 @@ expression, in which case we want to handle forms
differently."
define-global-minor-mode
define-globalized-minor-mode
easy-mmode-define-minor-mode
- define-minor-mode))
+ define-minor-mode
+ transient-define-prefix
+ transient-define-suffix
+ transient-define-infix
+ transient-define-argument))
t)
(and (eq (car-safe (car body)) 'interactive)
;; List of modes or just t.
@@ -378,6 +387,7 @@ don't include."
(let ((defs nil)
(load-name (loaddefs-generate--file-load-name file main-outfile))
(compute-prefixes t)
+ read-symbol-shorthands
local-outfile inhibit-autoloads)
(with-temp-buffer
(insert-file-contents file)
@@ -399,7 +409,22 @@ don't include."
(setq inhibit-autoloads (read (current-buffer)))))
(save-excursion
(when (re-search-forward "autoload-compute-prefixes: *" nil t)
- (setq compute-prefixes (read (current-buffer))))))
+ (setq compute-prefixes (read (current-buffer)))))
+ (save-excursion
+ ;; Since we're "open-coding", we have to repeat more
+ ;; complicated logic in `hack-local-variables'.
+ (when-let ((beg
+ (re-search-forward "read-symbol-shorthands: *" nil t)))
+ ;; `read-symbol-shorthands' alist ends with two parens.
+ (let* ((end (re-search-forward ")[;\n\s]*)"))
+ (commentless (replace-regexp-in-string
+ "\n\\s-*;+" ""
+ (buffer-substring beg end)))
+ (unsorted-shorthands (car (read-from-string commentless))))
+ (setq read-symbol-shorthands
+ (sort unsorted-shorthands
+ (lambda (sh1 sh2)
+ (> (length (car sh1)) (length (car sh2))))))))))
;; We always return the package version (even for pre-dumped
;; files).
@@ -473,27 +498,35 @@ don't include."
(when (and autoload-compute-prefixes
compute-prefixes)
- (when-let ((form (loaddefs-generate--compute-prefixes load-name)))
- ;; This output needs to always go in the main loaddefs.el,
- ;; regardless of `generated-autoload-file'.
- (push (list main-outfile file form) defs)))))
+ (with-demoted-errors "%S"
+ (when-let
+ ((form (loaddefs-generate--compute-prefixes load-name)))
+ ;; This output needs to always go in the main loaddefs.el,
+ ;; regardless of `generated-autoload-file'.
+ (push (list main-outfile file form) defs))))))
defs))
(defun loaddefs-generate--compute-prefixes (load-name)
(goto-char (point-min))
- (let ((prefs nil))
+ (let ((prefs nil)
+ (temp-obarray (obarray-make)))
;; Avoid (defvar <foo>) by requiring a trailing space.
(while (re-search-forward
"^(\\(def[^ \t\n]+\\)[ \t\n]+['(]*\\([^' ()\"\n]+\\)[\n \t]" nil t)
(unless (member (match-string 1) autoload-ignored-definitions)
- (let ((name (match-string-no-properties 2)))
- (when (save-excursion
- (goto-char (match-beginning 0))
- (or (bobp)
- (progn
- (forward-line -1)
- (not (looking-at ";;;###autoload")))))
- (push name prefs)))))
+ (let* ((name (match-string-no-properties 2))
+ ;; Consider `read-symbol-shorthands'.
+ (probe (let ((obarray temp-obarray))
+ (car (read-from-string name)))))
+ (when (symbolp probe)
+ (setq name (symbol-name probe))
+ (when (save-excursion
+ (goto-char (match-beginning 0))
+ (or (bobp)
+ (progn
+ (forward-line -1)
+ (not (looking-at ";;;###autoload")))))
+ (push name prefs))))))
(loaddefs-generate--make-prefixes prefs load-name)))
(defun loaddefs-generate--rubric (file &optional type feature compile)
diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el
index ffbb29615da..d3d71a36ee4 100644
--- a/lisp/emacs-lisp/map.el
+++ b/lisp/emacs-lisp/map.el
@@ -608,18 +608,30 @@ This allows using default values for `map-elt', which
can't be
done using `pcase--flip'.
KEY is the key sought in the map. DEFAULT is the default value."
+ ;; It's obsolete in Emacs>29, but `map.el' is distributed via GNU ELPA
+ ;; for earlier Emacsen.
+ (declare (obsolete _ "30.1"))
`(map-elt ,map ,key ,default))
(defun map--make-pcase-bindings (args)
"Return a list of pcase bindings from ARGS to the elements of a map."
- (mapcar (lambda (elt)
- (cond ((consp elt)
- `(app (map--pcase-map-elt ,(car elt) ,(caddr elt))
- ,(cadr elt)))
- ((keywordp elt)
- (let ((var (intern (substring (symbol-name elt) 1))))
- `(app (pcase--flip map-elt ,elt) ,var)))
- (t `(app (pcase--flip map-elt ',elt) ,elt))))
+ (mapcar (if (< emacs-major-version 30)
+ (lambda (elt)
+ (cond ((consp elt)
+ `(app (map--pcase-map-elt ,(car elt) ,(caddr elt))
+ ,(cadr elt)))
+ ((keywordp elt)
+ (let ((var (intern (substring (symbol-name elt) 1))))
+ `(app (pcase--flip map-elt ,elt) ,var)))
+ (t `(app (pcase--flip map-elt ',elt) ,elt))))
+ (lambda (elt)
+ (cond ((consp elt)
+ `(app (map-elt _ ,(car elt) ,(caddr elt))
+ ,(cadr elt)))
+ ((keywordp elt)
+ (let ((var (intern (substring (symbol-name elt) 1))))
+ `(app (map-elt _ ,elt) ,var)))
+ (t `(app (map-elt _ ',elt) ,elt)))))
args))
(defun map--make-pcase-patterns (args)
diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el
index db0cc515e46..ef056c7909b 100644
--- a/lisp/emacs-lisp/package-vc.el
+++ b/lisp/emacs-lisp/package-vc.el
@@ -501,8 +501,10 @@ This includes downloading missing dependencies, generating
autoloads, generating a package description file (used to
identify a package as a VC package later on), building
documentation and marking the package as installed."
- (let ((pkg-spec (package-vc--desc->spec pkg-desc))
- missing)
+ (let* ((pkg-spec (package-vc--desc->spec pkg-desc))
+ (lisp-dir (plist-get pkg-spec :lisp-dir))
+ (lisp-path (file-name-concat pkg-dir lisp-dir))
+ missing)
;; In case the package was installed directly from source, the
;; dependency list wasn't know beforehand, and they might have
@@ -519,7 +521,7 @@ documentation and marking the package as installed."
"\\|")
regexp-unmatchable))
(deps '()))
- (dolist (file (directory-files pkg-dir t "\\.el\\'" t))
+ (dolist (file (directory-files lisp-path t "\\.el\\'" t))
(unless (string-match-p ignored-files file)
(with-temp-buffer
(insert-file-contents file)
@@ -532,6 +534,7 @@ documentation and marking the package as installed."
(setq deps))))))
(dolist (dep deps)
(cl-callf version-to-list (cadr dep)))
+ (setf (package-desc-reqs pkg-desc) deps)
(setf missing (package-vc-install-dependencies (delete-dups deps)))
(setf missing (delq (assq (package-desc-name pkg-desc)
missing)
@@ -541,10 +544,8 @@ documentation and marking the package as installed."
(pkg-file (expand-file-name (package--description-file pkg-dir)
pkg-dir)))
;; Generate autoloads
(let* ((name (package-desc-name pkg-desc))
- (auto-name (format "%s-autoloads.el" name))
- (lisp-dir (plist-get pkg-spec :lisp-dir)))
- (package-generate-autoloads
- name (file-name-concat pkg-dir lisp-dir))
+ (auto-name (format "%s-autoloads.el" name)))
+ (package-generate-autoloads name lisp-path)
(when lisp-dir
(write-region
(with-temp-buffer
@@ -938,8 +939,8 @@ for the last released version of the package."
(interactive
(let* ((name (package-vc--read-package-name "Fetch package source: ")))
(list (cadr (assoc name package-archive-contents #'string=))
- (read-file-name "Clone into new or empty directory: " nil nil t nil
- (lambda (dir) (or (not (file-exists-p dir))
+ (read-directory-name "Clone into new or empty directory: " nil nil
+ (lambda (dir) (or (not (file-exists-p dir))
(directory-empty-p dir))))
(and current-prefix-arg :last-release))))
(package-vc--archives-initialize)
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 868373f46c2..fe7b10f569a 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -2610,7 +2610,8 @@ This is meant to be used only in the case the
byte-compiled files
are invalid due to changed byte-code, macros or the like."
(interactive)
(pcase-dolist (`(_ ,pkg-desc) package-alist)
- (package-recompile pkg-desc)))
+ (with-demoted-errors "Error while recompiling: %S"
+ (package-recompile pkg-desc))))
;;;###autoload
(defun package-autoremove ()
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 4754d4e720d..40d917795e3 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -131,6 +131,8 @@ FUN in `pred' and `app' can take one of the forms:
call it with one argument
(F ARG1 .. ARGn)
call F with ARG1..ARGn and EXPVAL as n+1'th argument
+ (F ARG1 .. _ .. ARGn)
+ call F, passing EXPVAL at the _ position.
FUN, BOOLEXP, and subsequent PAT can refer to variables
bound earlier in the pattern by a SYMBOL pattern.
@@ -163,8 +165,12 @@ Emacs Lisp manual for more information and examples."
;; (puthash (car cases) `(,exp ,cases ,@expansion) pcase--memoize-2)
expansion))))
-(declare-function help-fns--signature "help-fns"
- (function doc real-def real-function buffer))
+(defconst pcase--find-macro-def-regexp "(pcase-defmacro[\s\t\n]+%s[\s\t\n]*(")
+
+(with-eval-after-load 'find-func
+ (defvar find-function-regexp-alist)
+ (add-to-list 'find-function-regexp-alist
+ `(pcase-macro . pcase--find-macro-def-regexp)))
;; FIXME: Obviously, this will collide with nadvice's use of
;; function-documentation if we happen to advise `pcase'.
@@ -174,9 +180,10 @@ Emacs Lisp manual for more information and examples."
(defun pcase--make-docstring ()
(let* ((main (documentation (symbol-function 'pcase) 'raw))
(ud (help-split-fundoc main 'pcase)))
- ;; So that eg emacs -Q -l cl-lib --eval "(documentation 'pcase)" works,
- ;; where cl-lib is anything using pcase-defmacro.
(require 'help-fns)
+ (declare-function help-fns-short-filename "help-fns" (filename))
+ (declare-function help-fns--signature "help-fns"
+ (function doc real-def real-function buffer))
(with-temp-buffer
(insert (or (cdr ud) main))
;; Presentation Note: For conceptual continuity, we guarantee
@@ -197,11 +204,20 @@ Emacs Lisp manual for more information and examples."
(let* ((pair (pop more))
(symbol (car pair))
(me (cdr pair))
- (doc (documentation me 'raw)))
+ (doc (documentation me 'raw))
+ (filename (find-lisp-object-file-name me 'defun)))
(insert "\n\n-- ")
(setq doc (help-fns--signature symbol doc me
(indirect-function me)
nil))
+ (when filename
+ (save-excursion
+ (forward-char -1)
+ (insert (format-message " in `"))
+ (help-insert-xref-button (help-fns-short-filename filename)
+ 'help-function-def symbol filename
+ 'pcase-macro)
+ (insert (format-message "'."))))
(insert "\n" (or doc "Not documented.")))))
(let ((combined-doc (buffer-string)))
(if ud (help-add-fundoc-usage combined-doc (car ud)) combined-doc)))))
@@ -269,8 +285,8 @@ As with `pcase-let', BINDINGS are of the form (PATTERN
EXP), but the
EXP in each binding in BINDINGS can use the results of the destructuring
bindings that precede it in BINDINGS' order.
-Each EXP should match (i.e. be of compatible structure) to its
-respective PATTERN; a mismatch may signal an error or may go
+Each EXP should match its respective PATTERN (i.e. be of structure
+compatible to PATTERN); a mismatch may signal an error or may go
undetected, binding variables to arbitrary values, such as nil."
(declare (indent 1)
(debug ((&rest (pcase-PAT &optional form)) body)))
@@ -291,8 +307,8 @@ All EXPs are evaluated first, and then used to perform
destructuring
bindings by matching each EXP against its respective PATTERN. Then
BODY is evaluated with those bindings in effect.
-Each EXP should match (i.e. be of compatible structure) to its
-respective PATTERN; a mismatch may signal an error or may go
+Each EXP should match its respective PATTERN (i.e. be of structure
+compatible to PATTERN); a mismatch may signal an error or may go
undetected, binding variables to arbitrary values, such as nil."
(declare (indent 1) (debug pcase-let*))
(if (null (cdr bindings))
@@ -800,10 +816,10 @@ A and B can be one of:
#'compiled-function-p))))
(pcase--mutually-exclusive-p (cadr upat) otherpred))
'(:pcase--fail . nil))
- ;; Since we turn (or 'a 'b 'c) into (pred (pcase--flip (memq '(a b c))))
+ ;; Since we turn (or 'a 'b 'c) into (pred (memq _ '(a b c)))
;; try and preserve the info we get from that memq test.
- ((and (eq 'pcase--flip (car-safe (cadr upat)))
- (memq (cadr (cadr upat)) '(memq member memql))
+ ((and (memq (car-safe (cadr upat)) '(memq member memql))
+ (eq (cadr (cadr upat)) '_)
(eq 'quote (car-safe (nth 2 (cadr upat))))
(eq 'quote (car-safe pat)))
(let ((set (cadr (nth 2 (cadr upat)))))
@@ -851,7 +867,7 @@ A and B can be one of:
(defmacro pcase--flip (fun arg1 arg2)
"Helper function, used internally to avoid (funcall (lambda ...) ...)."
- (declare (debug (sexp body)))
+ (declare (debug (sexp body)) (obsolete _ "30.1"))
`(,fun ,arg2 ,arg1))
(defun pcase--funcall (fun arg vars)
@@ -872,9 +888,13 @@ A and B can be one of:
(let ((newsym (gensym "x")))
(push (list newsym arg) env)
(setq arg newsym)))
- (if (or (functionp fun) (not (consp fun)))
- `(funcall #',fun ,arg)
- `(,@fun ,arg)))))
+ (cond
+ ((or (functionp fun) (not (consp fun)))
+ `(funcall #',fun ,arg))
+ ((memq '_ fun)
+ (mapcar (lambda (x) (if (eq '_ x) arg x)) fun))
+ (t
+ `(,@fun ,arg))))))
(if (null env)
call
;; Let's not replace `vars' in `fun' since it's
@@ -935,7 +955,7 @@ Otherwise, it defers to REST which is a list of branches of
the form
;; Yes, we can use `memql' (or `member')!
((> (length simples) 1)
(pcase--u1 (cons `(match ,var
- . (pred (pcase--flip ,mem-fun ',simples)))
+ . (pred (,mem-fun _ ',simples)))
(cdr matches))
code vars
(if (null others) rest
@@ -1082,12 +1102,13 @@ The predicate is the logical-AND of:
(declare (debug (pcase-QPAT)))
(cond
((eq (car-safe qpat) '\,) (cadr qpat))
+ ((eq (car-safe qpat) '\,@) (error "Unsupported QPAT: %S" qpat))
((vectorp qpat)
`(and (pred vectorp)
(app length ,(length qpat))
,@(let ((upats nil))
(dotimes (i (length qpat))
- (push `(app (pcase--flip aref ,i) ,(list '\` (aref qpat i)))
+ (push `(app (aref _ ,i) ,(list '\` (aref qpat i)))
upats))
(nreverse upats))))
((consp qpat)
diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el
index 4c6553972c2..20077db9e60 100644
--- a/lisp/emacs-lisp/seq.el
+++ b/lisp/emacs-lisp/seq.el
@@ -619,12 +619,12 @@ SEQUENCE must be a sequence of numbers or markers."
(unless rest-marker
(pcase name
(`&rest
- (progn (push `(app (pcase--flip seq-drop ,index)
+ (progn (push `(app (seq-drop _ ,index)
,(seq--elt-safe args (1+ index)))
bindings)
(setq rest-marker t)))
(_
- (push `(app (pcase--flip seq--elt-safe ,index) ,name) bindings))))
+ (push `(app (seq--elt-safe _ ,index) ,name) bindings))))
(setq index (1+ index)))
bindings))
diff --git a/lisp/emacs-lisp/shortdoc.el b/lisp/emacs-lisp/shortdoc.el
index a6a49c72f74..cbb5618ffce 100644
--- a/lisp/emacs-lisp/shortdoc.el
+++ b/lisp/emacs-lisp/shortdoc.el
@@ -50,6 +50,17 @@
'((t :inherit variable-pitch))
"Face used for a section.")
+;;;###autoload
+(defun shortdoc--check (group functions)
+ (let ((keywords '( :no-manual :args :eval :no-eval :no-value :no-eval*
+ :result :result-string :eg-result :eg-result-string
:doc)))
+ (dolist (f functions)
+ (when (consp f)
+ (dolist (x f)
+ (when (and (keywordp x) (not (memq x keywords)))
+ (error "Shortdoc %s function `%s': bad keyword `%s'"
+ group (car f) x)))))))
+
;;;###autoload
(progn
(defvar shortdoc--groups nil)
@@ -118,6 +129,7 @@ A FUNC form can have any number of `:no-eval' (or
`:no-value'),
`:no-eval*', `:result', `:result-string', `:eg-result' and
`:eg-result-string' properties."
(declare (indent defun))
+ (shortdoc--check group functions)
`(progn
(setq shortdoc--groups (delq (assq ',group shortdoc--groups)
shortdoc--groups))
@@ -715,7 +727,7 @@ A FUNC form can have any number of `:no-eval' (or
`:no-value'),
:eval (plist-get '(a 1 b 2 c 3) 'b))
(plist-put
:no-eval (setq plist (plist-put plist 'd 4))
- :eq-result (a 1 b 2 c 3 d 4))
+ :eg-result (a 1 b 2 c 3 d 4))
(plist-member
:eval (plist-member '(a 1 b 2 c 3) 'b))
"Data About Lists"
@@ -735,9 +747,13 @@ A FUNC form can have any number of `:no-eval' (or
`:no-value'),
(intern
:eval (intern "abc"))
(intern-soft
+ :eval (intern-soft "list")
:eval (intern-soft "Phooey!"))
(make-symbol
:eval (make-symbol "abc"))
+ (gensym
+ :no-eval (gensym)
+ :eg-result g37)
"Comparing symbols"
(eq
:eval (eq 'abc 'abc)
@@ -748,7 +764,20 @@ A FUNC form can have any number of `:no-eval' (or
`:no-value'),
:eval (equal 'abc 'abc))
"Name"
(symbol-name
- :eval (symbol-name 'abc)))
+ :eval (symbol-name 'abc))
+ "Obarrays"
+ (obarray-make
+ :eval (obarray-make))
+ (obarrayp
+ :eval (obarrayp (obarray-make))
+ :eval (obarrayp nil))
+ (unintern
+ :no-eval (unintern "abc" my-obarray)
+ :eg-result t)
+ (mapatoms
+ :no-eval (mapatoms (lambda (symbol) (print symbol)) my-obarray))
+ (obarray-clear
+ :no-eval (obarray-clear my-obarray)))
(define-short-documentation-group comparison
"General-purpose"
diff --git a/lisp/emacs-lisp/shorthands.el b/lisp/emacs-lisp/shorthands.el
index 6348aaccf93..379fb0baec9 100644
--- a/lisp/emacs-lisp/shorthands.el
+++ b/lisp/emacs-lisp/shorthands.el
@@ -52,38 +52,26 @@
:version "28.1"
:group 'font-lock-faces)
-(defun shorthands--mismatch-from-end (str1 str2)
- "Tell index of first mismatch in STR1 and STR2, from end.
-The index is a valid 0-based index on STR1. Returns nil if STR1
-equals STR2. Return 0 if STR1 is a suffix of STR2."
- (cl-loop with l1 = (length str1) with l2 = (length str2)
- for i from 1
- for i1 = (- l1 i) for i2 = (- l2 i)
- while (eq (aref str1 i1) (aref str2 i2))
- if (zerop i2) return (if (zerop i1) nil i1)
- if (zerop i1) return 0
- finally (return i1)))
-
(defun shorthands-font-lock-shorthands (limit)
+ "Font lock until LIMIT considering `read-symbol-shorthands'."
(when read-symbol-shorthands
(while (re-search-forward
(concat "\\_<\\(" (rx lisp-mode-symbol) "\\)\\_>")
limit t)
(let* ((existing (get-text-property (match-beginning 1) 'face))
+ (print-name (match-string 1))
(probe (and (not (memq existing '(font-lock-comment-face
font-lock-string-face)))
- (intern-soft (match-string 1))))
- (sname (and probe (symbol-name probe)))
- (mismatch (and sname (shorthands--mismatch-from-end
- (match-string 1) sname)))
- (guess (and mismatch (1+ mismatch))))
- (when guess
- (when (and (< guess (1- (length (match-string 1))))
- ;; In bug#67390 we allow other separators
- (eq (char-syntax (aref (match-string 1) guess)) ?_))
- (setq guess (1+ guess)))
+ (intern-soft print-name)))
+ (symbol-name (and probe (symbol-name probe)))
+ (prefix (and symbol-name
+ (not (string-equal print-name symbol-name))
+ (car (assoc print-name
+ read-symbol-shorthands
+ #'string-prefix-p)))))
+ (when prefix
(add-face-text-property (match-beginning 1)
- (+ (match-beginning 1) guess)
+ (+ (match-beginning 1) (length prefix))
'elisp-shorthand-font-lock-face))))))
(font-lock-add-keywords 'emacs-lisp-mode '((shorthands-font-lock-shorthands))
t)
diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el
index 29775e77716..1ed1528c6d5 100644
--- a/lisp/emacs-lisp/trace.el
+++ b/lisp/emacs-lisp/trace.el
@@ -193,7 +193,7 @@ LEVEL is the trace level, VALUE value returned by FUNCTION."
;; Do this so we'll see strings:
(cl-prin1-to-string value)
ctx)))))
-
+
(defvar trace--timer nil)
(defun trace--display-buffer (buf)
diff --git a/lisp/epa-ks.el b/lisp/epa-ks.el
index c3c11bb0b0b..13840da0bd9 100644
--- a/lisp/epa-ks.el
+++ b/lisp/epa-ks.el
@@ -47,11 +47,8 @@ This is used by `epa-search-keys', for looking up public
keys."
(repeat :tag "Random pool"
(string :tag "Keyserver address"))
(const "keyring.debian.org")
- (const "keys.gnupg.net")
(const "keyserver.ubuntu.com")
(const "pgp.mit.edu")
- (const "pool.sks-keyservers.net")
- (const "zimmermann.mayfirst.org")
(string :tag "Custom keyserver"))
:version "28.1")
diff --git a/lisp/epa.el b/lisp/epa.el
index 53da3bf6cce..c29df18bb58 100644
--- a/lisp/epa.el
+++ b/lisp/epa.el
@@ -73,6 +73,17 @@ The command `epa-mail-encrypt' uses this."
:group 'epa
:version "24.4")
+(defcustom epa-keys-select-method 'buffer
+ "Method used to select keys in `epa-select-keys'.
+If the value is \\='buffer, the default, keys are selected via a
+pop-up buffer. If the value is \\='minibuffer, keys are selected
+via the minibuffer instead, using `completing-read-multiple'.
+Any other value is treated as \\='buffer."
+ :type '(choice (const :tag "Read keys from a pop-up buffer" buffer)
+ (const :tag "Read keys from minibuffer" minibuffer))
+ :group 'epa
+ :version "30.1")
+
;;; Faces
(defgroup epa-faces nil
@@ -450,6 +461,25 @@ q trust status questionable. - trust status unspecified.
(epa--marked-keys))
(kill-buffer epa-keys-buffer)))))
+(defun epa--select-keys-in-minibuffer (prompt keys)
+ (let* ((prompt (pcase-let ((`(,first ,second ,third)
+ (string-split prompt "\\."))
+ (hint "(separated by comma)"))
+ (if third
+ (format "%s %s. %s: " first hint second)
+ (format "%s %s: " first hint))))
+ (keys-alist
+ (seq-map
+ (lambda (key)
+ (cons (substring-no-properties
+ (epa--button-key-text key))
+ key))
+ keys))
+ (selected-keys (completing-read-multiple prompt keys-alist)))
+ (seq-map
+ (lambda (key) (cdr (assoc key keys-alist)))
+ selected-keys)))
+
;;;###autoload
(defun epa-select-keys (context prompt &optional names secret)
"Display a user's keyring and ask him to select keys.
@@ -459,7 +489,9 @@ NAMES is a list of strings to be matched with keys. If it
is nil, all
the keys are listed.
If SECRET is non-nil, list secret keys instead of public keys."
(let ((keys (epg-list-keys context names secret)))
- (epa--select-keys prompt keys)))
+ (pcase epa-keys-select-method
+ ('minibuffer (epa--select-keys-in-minibuffer prompt keys))
+ (_ (epa--select-keys prompt keys)))))
;;;; Key Details
diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el
index e379066b08e..9fc8a4d29f4 100644
--- a/lisp/erc/erc-backend.el
+++ b/lisp/erc/erc-backend.el
@@ -158,7 +158,6 @@
(declare-function erc-parse-user "erc" (string))
(declare-function erc-process-away "erc" (proc away-p))
(declare-function erc-process-ctcp-query "erc" (proc parsed nick login host))
-(declare-function erc-query-buffer-p "erc" (&optional buffer))
(declare-function erc-remove-channel-member "erc" (channel nick))
(declare-function erc-remove-channel-users "erc" nil)
(declare-function erc-remove-user "erc" (nick))
@@ -254,6 +253,11 @@ Entries are of the form:
or
(PARAMETER) if no value is provided.
+where PARAMETER is a string and VALUE is a string or nil. For
+compatibility, a raw parameter of the form \"FOO=\" becomes
+(\"FOO\" . \"\") even though it's equivalent to the preferred
+canonical form \"FOO\" and its lisp representation (\"FOO\").
+
Some examples of possible parameters sent by servers:
CHANMODES=b,k,l,imnpst - list of supported channel modes
CHANNELLEN=50 - maximum length of channel names
@@ -273,7 +277,8 @@ WALLCHOPS - supports sending messages to all operators in a
channel")
(defvar-local erc--isupport-params nil
"Hash map of \"ISUPPORT\" params.
Keys are symbols. Values are lists of zero or more strings with hex
-escapes removed.")
+escapes removed. ERC normalizes incoming parameters of the form
+\"FOO=\" to (FOO).")
;;; Server and connection state
@@ -1474,10 +1479,12 @@ for decoding."
(let ((args (erc-response.command-args parsed-response))
(decode-target nil)
(decoded-args ()))
+ ;; FIXME this should stop after the first match.
(dolist (arg args nil)
(when (string-match "^[#&].*" arg)
(setq decode-target arg)))
(when (stringp decode-target)
+ ;; FIXME `decode-target' should be passed as TARGET.
(setq decode-target (erc-decode-string-from-target decode-target nil)))
(setf (erc-response.unparsed parsed-response)
(erc-decode-string-from-target
@@ -2150,10 +2157,6 @@ Then display the welcome message."
;;
;; > The server SHOULD send "X", not "X="; this is the normalized form.
;;
- ;; Note: for now, assume the server will only send non-empty values,
- ;; possibly with printable ASCII escapes. Though in practice, the
- ;; only two escapes we're likely to see are backslash and space,
- ;; meaning the pattern is too liberal.
(let (case-fold-search)
(mapcar
(lambda (v)
@@ -2164,7 +2167,9 @@ Then display the welcome message."
(string-match "[\\]x[0-9A-F][0-9A-F]" v start))
(setq m (substring v (+ 2 (match-beginning 0)) (match-end 0))
c (string-to-number m 16))
- (if (<= ?\ c ?~)
+ ;; In practice, this range is too liberal. The only
+ ;; escapes we're likely to see are ?\\, ?=, and ?\s.
+ (if (<= ?\s c ?~)
(setq v (concat (substring v 0 (match-beginning 0))
(string c)
(substring v (match-end 0)))
@@ -2189,8 +2194,9 @@ primitive value."
(or erc-server-parameters
(erc-with-server-buffer
erc-server-parameters)))))
- (if (cdr v)
- (erc--parse-isupport-value (cdr v))
+ (if-let ((val (cdr v))
+ ((not (string-empty-p val))))
+ (erc--parse-isupport-value val)
'--empty--)))))
(pcase value
('--empty-- (unless single (list key)))
diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el
index abcdc4c8843..8388efe062c 100644
--- a/lisp/erc/erc-common.el
+++ b/lisp/erc/erc-common.el
@@ -171,7 +171,7 @@ Derived from the advertised \"PREFIX\" ISUPPORT parameter."
;; After dropping 28, we can use prefixed "erc-autoload" cookies.
(defun erc--normalize-module-symbol (symbol)
- "Return preferred SYMBOL for `erc--modules'."
+ "Return preferred SYMBOL for `erc--module'."
(while-let ((canonical (get symbol 'erc--module))
((not (eq canonical symbol))))
(setq symbol canonical))
diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el
index dede833a93d..b5b8fbaf8ab 100644
--- a/lisp/erc/erc-compat.el
+++ b/lisp/erc/erc-compat.el
@@ -31,51 +31,11 @@
;;; Code:
-(require 'compat nil 'noerror)
+(require 'compat)
(eval-when-compile (require 'cl-lib))
-;; Except for the "erc-" namespacing, these two definitions should be
-;; continuously updated to match the latest upstream ones verbatim.
-;; Although they're pretty simple, it's likely not worth checking for
-;; and possibly deferring to the non-prefixed versions.
-;;
-;; BEGIN Compat macros
-
-;;;; Macros for extended compatibility function calls
-
-(defmacro erc-compat-function (fun)
- "Return compatibility function symbol for FUN.
-
-If the Emacs version provides a sufficiently recent version of
-FUN, the symbol FUN is returned itself. Otherwise the macro
-returns the symbol of a compatibility function which supports the
-behavior and calling convention of the current stable Emacs
-version. For example Compat 29.1 will provide compatibility
-functions which implement the behavior and calling convention of
-Emacs 29.1.
-
-See also `compat-call' to directly call compatibility functions."
- (let ((compat (intern (format "compat--%s" fun))))
- `#',(if (fboundp compat) compat fun)))
-
-(defmacro erc-compat-call (fun &rest args)
- "Call compatibility function or macro FUN with ARGS.
-
-A good example function is `plist-get' which was extended with an
-additional predicate argument in Emacs 29.1. The compatibility
-function, which supports this additional argument, can be
-obtained via (compat-function plist-get) and called
-via (compat-call plist-get plist prop predicate). It is not
-possible to directly call (plist-get plist prop predicate) on
-Emacs older than 29.1, since the original `plist-get' function
-does not yet support the predicate argument. Note that the
-Compat library never overrides existing functions.
-
-See also `compat-function' to lookup compatibility functions."
- (let ((compat (intern (format "compat--%s" fun))))
- `(,(if (fboundp compat) compat fun) ,@args)))
-
-;; END Compat macros
+(define-obsolete-function-alias 'erc-compat-function #'compat-function "30.1")
+(define-obsolete-function-alias 'erc-compat-call #'compat-call "30.1")
;;;###autoload(autoload 'erc-define-minor-mode "erc-compat")
(define-obsolete-function-alias 'erc-define-minor-mode
@@ -102,7 +62,7 @@ See `erc-encoding-coding-alist'."
(defun erc-set-write-file-functions (new-val)
(declare (obsolete nil "28.1"))
- (set (make-local-variable 'write-file-functions) new-val))
+ (setq-local write-file-functions new-val))
(defvar erc-emacs-build-time
(if (or (stringp emacs-build-time) (not emacs-build-time))
diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el
index b91ce007087..aa12b807fbc 100644
--- a/lisp/erc/erc-fill.el
+++ b/lisp/erc/erc-fill.el
@@ -44,11 +44,7 @@
(define-erc-module fill nil
"Manage filling in ERC buffers.
ERC fill mode is a global minor mode. When enabled, messages in
-the channel buffers are filled."
- ;; FIXME ensure a consistent ordering relative to hook members from
- ;; other modules. Ideally, this module's processing should happen
- ;; after "morphological" modifications to a message's text but
- ;; before superficial decorations.
+channel buffers are filled. See also `erc-fill-wrap-mode'."
((add-hook 'erc-insert-modify-hook #'erc-fill 60)
(add-hook 'erc-send-modify-hook #'erc-fill 60))
((remove-hook 'erc-insert-modify-hook #'erc-fill)
@@ -425,8 +421,11 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'."
"<remap> <erc-bol>" #'erc-fill--wrap-beginning-of-line)
(defvar erc-button-mode)
+(defvar erc-scrolltobottom-mode)
(defvar erc-legacy-invisible-bounds-p)
+(defvar erc--fill-wrap-scrolltobottom-exempt-p nil)
+
(defun erc-fill--wrap-ensure-dependencies ()
(with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p))
(when erc-legacy-invisible-bounds-p
@@ -439,6 +438,10 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'."
(unless erc-fill-mode
(push 'fill missing-deps)
(erc-fill-mode +1))
+ (unless (or erc-scrolltobottom-mode erc--fill-wrap-scrolltobottom-exempt-p
+ (memq 'scrolltobottom erc-modules))
+ (push 'scrolltobottom missing-deps)
+ (erc-scrolltobottom-mode +1))
(when erc-fill-wrap-merge
(require 'erc-button)
(unless erc-button-mode
@@ -459,27 +462,25 @@ is 0, reset to value of `erc-fill-wrap-visual-keys'."
;;;###autoload(put 'fill-wrap 'erc--feature 'erc-fill)
(define-erc-module fill-wrap nil
"Fill style leveraging `visual-line-mode'.
+
This module displays nicks overhanging leftward to a common
-offset, as determined by the option `erc-fill-static-center'.
-And it \"wraps\" messages at a common margin width, as determined
-by the option `erc-fill-wrap-margin-width'. To use it, either
-include `fill-wrap' in `erc-modules' or set `erc-fill-function'
-to `erc-fill-wrap'. Most users will want to enable the
-`scrolltobottom' module as well.
-
-During sessions in which this module is active, use
-\\[erc-fill-wrap-nudge] to adjust the width of the indent and the
-stamp margin, and use \\[erc-fill-wrap-toggle-truncate-lines] for
-cycling between logical- and screen-line oriented command
-movement. Similarly, use \\[erc-fill-wrap-refill-buffer] to fix
-alignment problems after running certain commands, like
-`text-scale-adjust'. Also see related stylistic options
-`erc-fill-wrap-merge', and `erc-fill-wrap-merge-indicator'.
-\(Hint: in narrow windows, where is space tight, try setting
-`erc-fill-static-center' to 1. And if you also use the option
-`erc-fill-wrap-merge-indicator', set that to value-menu item
-\"Leading MIDDLE DOT sans gap\" or one of the various
-\"trailing\" items.)
+offset, as determined by the option `erc-fill-static-center'. It
+also \"wraps\" messages at a common width, as determined by the
+option `erc-fill-wrap-margin-width'. To use it, either include
+`fill-wrap' in `erc-modules' or set `erc-fill-function' to
+`erc-fill-wrap'.
+
+Once enabled, use \\[erc-fill-wrap-nudge] to adjust the width of
+the indent and the stamp margin. And For cycling between
+logical- and screen-line oriented command movement, see
+\\[erc-fill-wrap-toggle-truncate-lines]. Similarly, use
+\\[erc-fill-wrap-refill-buffer] to fix alignment problems after
+running certain commands, like `text-scale-adjust'. Also see
+related stylistic options `erc-fill-wrap-merge', and
+`erc-fill-wrap-merge-indicator'. (Hint: in narrow windows, try
+setting `erc-fill-static-center' to 1, and if you use
+`erc-fill-wrap-merge-indicator', choose \"Leading MIDDLE DOT sans
+gap\" or one of the \"trailing\" items from the Customize menu.)
This module imposes various restrictions on the appearance of
timestamps. Most notably, it insists on displaying them in the
@@ -497,11 +498,12 @@ a workaround provided by `erc-stamp-prefix-log-filter',
which
strips trailing stamps from logged messages and instead prepends
them to every line.
-As a so-called \"local\" module, `fill-wrap' depends on the
-global modules `fill', `stamp', and `button'; it activates them
-as needed when initializing. Please note that enabling and
-disabling this module by invoking one of its minor-mode toggles
-is not recommended."
+A so-called \"local\" module, `fill-wrap' depends on the global
+modules `fill', `stamp', `button', and `scrolltobottom'. It
+activates them as needed when initializing and leaves them
+enabled when shutting down. To opt out of `scrolltobottom'
+specifically, disable its minor mode, `erc-scrolltobottom-mode',
+via `erc-fill-wrap-mode-hook'."
((erc-fill--wrap-ensure-dependencies)
(erc--restore-initialize-priors erc-fill-wrap-mode
erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys
@@ -832,7 +834,7 @@ decorations applied by third-party modules."
(line (count-screen-lines (window-start) (window-point))))
(when (zerop arg)
(setq arg 1))
- (erc-compat-call
+ (compat-call
set-transient-map
(let ((map (make-sparse-keymap)))
(dolist (key '(?= ?- ?0))
diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el
index 8293994c5d4..7e30b1060fd 100644
--- a/lisp/erc/erc-goodies.el
+++ b/lisp/erc/erc-goodies.el
@@ -83,7 +83,7 @@ be experimental. It currently only works with Emacs 28+."
(when (and erc-scrolltobottom-all (< emacs-major-version 28))
(erc-button--display-error-notice-with-keys
"Option `erc-scrolltobottom-all' requires Emacs 28+. Disabling.")
- (setopt erc-scrolltobottom-all nil))
+ (setq erc-scrolltobottom-all nil))
(unless erc--updating-modules-p (erc-buffer-do #'erc--scrolltobottom-setup))
(if erc-scrolltobottom-all
(progn
diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el
index 99c3c0563d0..1b26afa1164 100644
--- a/lisp/erc/erc-networks.el
+++ b/lisp/erc/erc-networks.el
@@ -1123,10 +1123,27 @@ TARGET to be an `erc--target' object."
(lambda ()
(when (and erc--target (eq (erc--target-symbol erc--target)
(erc--target-symbol target)))
- (let ((oursp (if (erc--target-channel-local-p target)
- (equal announced erc-server-announced-name)
- (erc-networks--id-equal-p identity erc-networks--id))))
- (funcall (if oursp on-dupe on-collision))))))))
+ ;; When a server sends administrative queries immediately
+ ;; after connection registration and before the session has a
+ ;; net-id, the buffer remains orphaned until reassociated
+ ;; here retroactively.
+ (unless erc-networks--id
+ (let ((id (erc-with-server-buffer erc-networks--id))
+ (server-buffer (process-buffer erc-server-process)))
+ (apply #'erc-button--display-error-notice-with-keys
+ server-buffer
+ (concat "Missing network session (ID) for %S. "
+ (if id "Using `%S' from %S." "Ignoring."))
+ (current-buffer)
+ (and id (list (erc-networks--id-symbol
+ (setq erc-networks--id id))
+ server-buffer)))))
+ (when erc-networks--id
+ (let ((oursp (if (erc--target-channel-local-p target)
+ (equal announced erc-server-announced-name)
+ (erc-networks--id-equal-p identity
+ erc-networks--id))))
+ (funcall (if oursp on-dupe on-collision)))))))))
(defconst erc-networks--qualified-sep "@"
"Separator used for naming a target buffer.")
diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el
index e3d28aa60dd..a81a3869436 100644
--- a/lisp/erc/erc-speedbar.el
+++ b/lisp/erc/erc-speedbar.el
@@ -566,8 +566,9 @@ The INDENT level is ignored."
(defun erc-speedbar--reset-last-ran-on-timer ()
"Reset `erc-speedbar--last-ran'."
(when speedbar-buffer
- (setf (buffer-local-value 'erc-speedbar--last-ran speedbar-buffer)
- (current-time))))
+ (with-suppressed-warnings ((obsolete buffer-local-value)) ; <=29
+ (setf (buffer-local-value 'erc-speedbar--last-ran speedbar-buffer)
+ (current-time)))))
;;;###autoload(autoload 'erc-nickbar-mode "erc-speedbar" nil t)
(define-erc-module nickbar nil
diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el
index 558afd19427..a8190a2c94a 100644
--- a/lisp/erc/erc-stamp.el
+++ b/lisp/erc/erc-stamp.el
@@ -184,7 +184,7 @@ from entering them and instead jump over them."
(add-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect)
(add-hook 'erc--pre-clear-functions #'erc-stamp--reset-on-clear 40)
(unless erc--updating-modules-p (erc-buffer-do #'erc-stamp--setup)))
- ((remove-hook 'erc-mode-hook #'erc-munge-invisibility-spec)
+ ((remove-hook 'erc-mode-hook #'erc-stamp--setup)
(remove-hook 'erc-insert-modify-hook #'erc-add-timestamp)
(remove-hook 'erc-send-modify-hook #'erc-add-timestamp)
(remove-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect)
@@ -198,6 +198,7 @@ from entering them and instead jump over them."
"Escape hatch for omitting stamps when first char is invisible.")
(defun erc-stamp--recover-on-reconnect ()
+ "Attempt to restore \"last-inserted\" snapshots from prior session."
(when-let ((priors (or erc--server-reconnecting erc--target-priors)))
(dolist (var '(erc-timestamp-last-inserted
erc-timestamp-last-inserted-left
@@ -827,6 +828,7 @@ left-sided stamps and date stamps inserted by this
function."
;; 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."
+ (defvar current-time-list) ; <=28
(let* ((current-time-list) ; flag
(decoded (decode-time current-time erc-stamp--tz)))
(setf (decoded-time-second decoded) 0
@@ -854,12 +856,20 @@ Return the empty string if FORMAT is nil."
(defvar-local erc-stamp--csf-props-updated-p nil)
-;; This function is used to munge `buffer-invisibility-spec' to an
-;; appropriate value. Currently, it only handles timestamps, thus its
-;; location. If you add other features which affect invisibility,
-;; please modify this function and move it to a more appropriate
-;; location.
-(defun erc-munge-invisibility-spec ()
+(define-obsolete-function-alias 'erc-munge-invisibility-spec
+ #'erc-stamp--manage-local-options-state "30.1"
+ "Perform setup and teardown of `stamp'-owned options.
+
+Note that this function's role in practice has long defied its
+stated mandate as claimed in a now deleted comment, which
+envisioned it as evolving into a central toggle for modifying
+`buffer-invisibility-spec' on behalf of options and features
+ERC-wide.")
+(defun erc-stamp--manage-local-options-state ()
+ "Perform local setup and teardown for `stamp'-owned options.
+For `erc-timestamp-intangible', toggle `cursor-intangible-mode'.
+For `erc-echo-timestamps', integrate with `cursor-sensor-mode'.
+For `erc-hide-timestamps, modify `buffer-invisibility-spec'."
(if erc-timestamp-intangible
(cursor-intangible-mode +1) ; idempotent
(when (bound-and-true-p cursor-intangible-mode)
@@ -869,10 +879,12 @@ Return the empty string if FORMAT is nil."
(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)
+ (setq erc-stamp--csf-props-updated-p
+ (alist-get 'erc-stamp--csf-props-updated-p
+ (or erc--server-reconnecting erc--target-priors)))
(unless erc-stamp--csf-props-updated-p
(setq erc-stamp--csf-props-updated-p t)
+ ;; Spoof `erc--ts' as being non-nil.
(let ((erc--msg-props (map-into '((erc--ts . t)) 'hash-table)))
(with-silent-modifications
(erc--traverse-inserted
@@ -902,9 +914,9 @@ Return the empty string if FORMAT is nil."
(defun erc-stamp--setup ()
"Enable or disable buffer-local `erc-stamp-mode' modifications."
(if erc-stamp-mode
- (erc-munge-invisibility-spec)
+ (erc-stamp--manage-local-options-state)
(let (erc-echo-timestamps erc-hide-timestamps erc-timestamp-intangible)
- (erc-munge-invisibility-spec))
+ (erc-stamp--manage-local-options-state))
;; Undo local mods from `erc-insert-timestamp-left-and-right'.
(erc-stamp--date-mode -1) ; kills `erc-timestamp-last-inserted-left'
(kill-local-variable 'erc-stamp--last-stamp)
@@ -916,7 +928,7 @@ Return the empty string if FORMAT is nil."
"Hide timestamp information from display."
(interactive)
(setq erc-hide-timestamps t)
- (erc-munge-invisibility-spec))
+ (erc-stamp--manage-local-options-state))
(defun erc-show-timestamps ()
"Show timestamp information on display.
@@ -924,7 +936,7 @@ This function only works if `erc-timestamp-format' was
previously
set, and timestamping is already active."
(interactive)
(setq erc-hide-timestamps nil)
- (erc-munge-invisibility-spec))
+ (erc-stamp--manage-local-options-state))
(defun erc-toggle-timestamps ()
"Hide or show timestamps in ERC buffers.
@@ -938,7 +950,7 @@ enabled when the message was inserted."
(setq erc-hide-timestamps t))
(mapc (lambda (buffer)
(with-current-buffer buffer
- (erc-munge-invisibility-spec)))
+ (erc-stamp--manage-local-options-state)))
(erc-buffer-list)))
(defvar-local erc-stamp--last-stamp nil)
diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index edac1060c3e..cce3b2508fb 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -135,6 +135,13 @@ concerning buffers."
"Running scripts at startup and with /LOAD."
:group 'erc)
+;; Add `custom-loads' features for group symbols missing from a
+;; supported Emacs version, possibly because they belong to a new ERC
+;; library. These groups all share their library's feature name.
+;;;###autoload(dolist (symbol '( erc-sasl erc-spelling ; 29
+;;;###autoload erc-imenu erc-nicks)) ; 30
+;;;###autoload (custom-add-load symbol symbol))
+
(defvar erc-message-parsed) ; only known to this file
(defvar erc--msg-props nil
@@ -1531,7 +1538,7 @@ Bound to local variables from an existing (logical)
session's
buffer during local-module setup and `erc-mode-hook' activation.")
(defmacro erc--restore-initialize-priors (mode &rest vars)
- "Restore local VARS for MODE from a previous session."
+ "Restore local VARS for local minor MODE from a previous session."
(declare (indent 1))
(let ((priors (make-symbol "priors"))
(initp (make-symbol "initp"))
@@ -1541,6 +1548,8 @@ buffer during local-module setup and `erc-mode-hook'
activation.")
(push `(,k (if ,initp (alist-get ',k ,priors) ,(pop vars))) forms))
`(let* ((,priors (or erc--server-reconnecting erc--target-priors))
(,initp (and ,priors (alist-get ',mode ,priors))))
+ (unless (local-variable-if-set-p ',mode)
+ (error "Not a local minor mode var: %s" ',mode))
(setq ,@(mapcan #'identity (nreverse forms))))))
(defun erc--target-from-string (string)
@@ -1654,11 +1663,7 @@ If BUFFER is nil, the current buffer is used."
(defun erc-query-buffer-p (&optional buffer)
"Return non-nil if BUFFER is an ERC query buffer.
If BUFFER is nil, the current buffer is used."
- (with-current-buffer (or buffer (current-buffer))
- (let ((target (erc-target)))
- (and (eq major-mode 'erc-mode)
- target
- (not (memq (aref target 0) '(?# ?& ?+ ?!)))))))
+ (not (erc-channel-p (or buffer (current-buffer)))))
(defun erc-ison-p (nick)
"Return non-nil if NICK is online."
@@ -1873,18 +1878,20 @@ buries those."
:group 'erc-buffers
:type 'boolean)
-(defun erc-channel-p (channel)
- "Return non-nil if CHANNEL seems to be an IRC channel name."
- (cond ((stringp channel)
- (memq (aref channel 0)
- (if-let ((types (erc--get-isupport-entry 'CHANTYPES 'single)))
- (append types nil)
- '(?# ?& ?+ ?!))))
- ((and-let* (((bufferp channel))
- ((buffer-live-p channel))
- (target (buffer-local-value 'erc--target channel)))
- (erc-channel-p (erc--target-string target))))
- (t nil)))
+(defvar erc--fallback-channel-prefixes "#&"
+ "Prefix chars for distinguishing channel targets when CHANTYPES is unknown.")
+
+(defun erc-channel-p (target)
+ "Return non-nil if TARGET is a valid channel name or a channel buffer."
+ (cond ((stringp target)
+ (and-let*
+ (((not (string-empty-p target)))
+ (value (let ((entry (erc--get-isupport-entry 'CHANTYPES)))
+ (if entry (cadr entry) erc--fallback-channel-prefixes)))
+ ((erc--strpos (aref target 0) value)))))
+ ((and-let* (((buffer-live-p target))
+ (target (buffer-local-value 'erc--target target))
+ ((erc--target-channel-p target)))))))
;; For the sake of compatibility, a historical quirk concerning this
;; option, when nil, has been preserved: all buffers are suffixed with
@@ -2183,13 +2190,17 @@ buffer rather than a server buffer.")
(cl-pushnew mod (if (get mod 'erc--module) built-in third-party)))
`(,@(sort built-in #'string-lessp) ,@(nreverse third-party))))
+;;;###autoload(custom-autoload 'erc-modules "erc")
+
(defcustom erc-modules '( autojoin button completion fill imenu irccontrols
list match menu move-to-prompt netsplit
networks readonly ring stamp track)
- "A list of modules which ERC should enable.
-If you set the value of this without using `customize' remember to call
-\(erc-update-modules) after you change it. When using `customize', modules
-removed from the list will be disabled."
+ "Modules to enable while connecting.
+When modifying this option in lisp code, use a Custom-friendly
+facilitator, like `setopt', or call `erc-update-modules'
+afterward. This ensures a consistent ordering and disables
+removed modules. It also gives packages access to the hook
+`erc-before-connect'."
:get (lambda (sym)
;; replace outdated names with their newer equivalents
(erc-migrate-modules (symbol-value sym)))
@@ -2473,29 +2484,22 @@ nil."
(cl-assert (= (point) (point-max)))))
(defun erc-open (&optional server port nick full-name
- connect passwd tgt-list channel process
+ connect passwd _tgt-list channel process
client-certificate user id)
- "Connect to SERVER on PORT as NICK with USER and FULL-NAME.
-
-If CONNECT is non-nil, connect to the server. Otherwise assume
-already connected and just create a separate buffer for the new
-target given by CHANNEL, meaning these parameters are mutually
-exclusive. Note that CHANNEL may also be a query; its name has
-been retained for historical reasons.
-
-Use PASSWD as user password on the server. If TGT-LIST is
-non-nil, use it to initialize `erc-default-recipients'.
-
-CLIENT-CERTIFICATE, if non-nil, should either be a list where the
-first element is the file name of the private key corresponding
-to a client certificate and the second element is the file name
-of the client certificate itself to use when connecting over TLS,
-or t, which means that `auth-source' will be queried for the
-private key and the certificate.
-
-When non-nil, ID should be a symbol for identifying the connection.
-
-Returns the buffer for the given server or channel."
+ "Return a new or reinitialized server or target buffer.
+If CONNECT is non-nil, connect to SERVER and return its new or
+reassociated buffer. Otherwise, assume PROCESS is non-nil and belongs
+to an active session, and return a new or refurbished target buffer for
+CHANNEL, which may also be a query target (the parameter name remains
+for historical reasons). Pass SERVER, PORT, NICK, USER, FULL-NAME, and
+PASSWD to `erc-determine-parameters' for preserving as session-local
+variables. Do something similar for CLIENT-CERTIFICATE and ID, which
+should be as described by `erc-tls'.
+
+Note that ERC ignores TGT-LIST and initializes `erc-default-recipients'
+with CHANNEL as its only member. Note also that this function has the
+side effect of setting the current buffer to the one it returns. Use
+`with-current-buffer' or `save-excursion' to nullify this effect."
(let* ((target (and channel (erc--target-from-string channel)))
(buffer (erc-get-buffer-create server port nil target id))
(old-buffer (current-buffer))
@@ -2532,7 +2536,7 @@ Returns the buffer for the given server or channel."
;; connection parameters
(setq erc-server-process process)
;; stack of default recipients
- (setq erc-default-recipients tgt-list)
+ (when channel (setq erc-default-recipients (list channel)))
(when target
(setq erc--target target
erc-network (erc-network)))
@@ -2768,8 +2772,9 @@ PORT, NICK, and PASSWORD, along with USER and FULL-NAME
when
given a prefix argument. Non-interactively, expect the rarely
needed ID parameter, when non-nil, to be a symbol or a string for
naming the server buffer and identifying the connection
-unequivocally. (See Info node `(erc) Connecting' for details
-about all mentioned parameters.)
+unequivocally. Once connected, return the server buffer. (See
+Info node `(erc) Connecting' for details about all mentioned
+parameters.)
Together with `erc-tls', this command serves as the main entry
point for ERC, the powerful, modular, and extensible IRC client.
@@ -3828,14 +3833,14 @@ TYPE, when non-nil, to be a symbol handled by
string MSG). Expect BUFFER to be among the sort accepted by the
function `erc-display-line'.
-Expect BUFFER to be a live `erc-mode' buffer, a list of such
-buffers, or the symbols `all' or `active'. If `all', insert
-STRING in all buffers for the current session. If `active',
-defer to the function `erc-active-buffer', which may return the
-session's server buffer if the previously active buffer has been
-killed. If BUFFER is nil or a network process, pretend it's set
-to the appropriate server buffer. Otherwise, use the current
-buffer.
+When non-nil, expect BUFFER to be a live `erc-mode' buffer, a
+list of such buffers, or the symbols `all' or `active'. If
+`all', insert STRING in all buffers for the current session. If
+`active', defer to the function `erc-active-buffer', which may
+return the session's server buffer if the previously active
+buffer has been killed. If BUFFER is nil or a network process,
+pretend it's set to the appropriate server buffer. Otherwise,
+use the current buffer.
When TYPE is a list of symbols, call handlers from left to right
without influencing how they behave when encountering existing
@@ -3848,11 +3853,10 @@ being (erc-error-face erc-notice-face) throughout MSG
when
`erc-notice-highlight-type' is left at its default, `all'.
As of ERC 5.6, assume third-party code will use this function
-instead of lower-level ones, like `erc-insert-line', when needing
-ERC to process arbitrary informative messages as if they'd been
-sent from a server. That is, guarantee \"local\" messages, for
-which PARSED is typically nil, will be subject to buttonizing,
-filling, and other effects."
+instead of lower-level ones, like `erc-insert-line', to insert
+arbitrary informative messages as if sent by the server. That
+is, tell modules to treat a \"local\" message for which PARSED is
+nil like any other server-sent message."
(let* ((erc--msg-props
(or erc--msg-props
(let ((table (make-hash-table))
@@ -4042,16 +4046,42 @@ this function from interpreting the line as a command."
;; Input commands handlers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun erc-cmd-AMSG (line)
- "Send LINE to all channels of the current server that you are on."
- (interactive "sSend to all channels you're on: ")
- (setq line (erc-trim-string line))
+(defun erc--connected-and-joined-p ()
+ (and (erc--current-buffer-joined-p)
+ erc-server-connected))
+
+(defun erc-cmd-GMSG (line)
+ "Send LINE to all channels on all networks you are on."
+ (setq line (string-remove-prefix " " line))
(erc-with-all-buffers-of-server nil
- (lambda ()
- (erc-channel-p (erc-default-target)))
+ #'erc--connected-and-joined-p
+ (erc-send-message line)))
+(put 'erc-cmd-GMSG 'do-not-parse-args t)
+
+(defun erc-cmd-AMSG (line)
+ "Send LINE to all channels of the current network.
+Interactively, prompt for the line of text to send."
+ (interactive "sSend to all channels on this network: ")
+ (setq line (string-remove-prefix " " line))
+ (erc-with-all-buffers-of-server erc-server-process
+ #'erc--connected-and-joined-p
(erc-send-message line)))
(put 'erc-cmd-AMSG 'do-not-parse-args t)
+(defun erc-cmd-GME (line)
+ "Send LINE as an action to all channels on all networks you are on."
+ (erc-with-all-buffers-of-server nil
+ #'erc--connected-and-joined-p
+ (erc-cmd-ME line)))
+(put 'erc-cmd-GME 'do-not-parse-args t)
+
+(defun erc-cmd-AME (line)
+ "Send LINE as an action to all channels on the current network."
+ (erc-with-all-buffers-of-server erc-server-process
+ #'erc--connected-and-joined-p
+ (erc-cmd-ME line)))
+(put 'erc-cmd-AME 'do-not-parse-args t)
+
(defun erc-cmd-SAY (line)
"Send LINE to the current query or channel as a message, not a command.
@@ -6810,7 +6840,7 @@ stand-in from the fallback value \"(qaohv)~&@%+\"."
"Return numeric rank for CHAR or nil if unknown.
For example, given letters \"qaohv\" return 1 for ?v, 2 for ?h,
and 4 for ?o, etc. If given, expect PARSED-PREFIX to be a
-`erc--parse-prefix' object. With FROM-PREFIX-P, expect CHAR to
+`erc--parsed-prefix' object. With FROM-PREFIX-P, expect CHAR to
be a prefix instead."
(and-let* ((obj (or parsed-prefix (erc--parsed-prefix)))
(pos (erc--strpos char (if from-prefix-p
@@ -9487,6 +9517,7 @@ guarantee that the input method functions properly for the
purpose of typing within the ERC prompt."
(when (and (eq major-mode 'erc-mode)
(fboundp 'set-text-conversion-style))
+ (defvar text-conversion-style) ; avoid free variable warning on <=29
(if (>= (point) (erc-beg-of-input-line))
(unless (eq text-conversion-style 'action)
(set-text-conversion-style 'action))
diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el
index c3c3fea691a..23028576f45 100644
--- a/lisp/eshell/em-unix.el
+++ b/lisp/eshell/em-unix.el
@@ -590,7 +590,7 @@ Rename SOURCE to DEST, or move SOURCE(s) to DIRECTORY.
:external "cp"
:show-usage
:usage "[OPTION]... SOURCE DEST
- or: cp [OPTION]... SOURCE... DIRECTORY
+ or: cp [OPTION]... SOURCE... DIRECTORY
Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.")
(if archive
(setq preserve t no-dereference t em-recursive t))
@@ -618,11 +618,11 @@ Copy SOURCE to DEST, or multiple SOURCE(s) to DIRECTORY.")
:preserve-args
:external "ln"
:show-usage
- :usage "[OPTION]... TARGET [LINK_NAME]
- or: ln [OPTION]... TARGET... DIRECTORY
-Create a link to the specified TARGET with optional LINK_NAME. If there is
-more than one TARGET, the last argument must be a directory; create links
-in DIRECTORY to each TARGET. Create hard links by default, symbolic links
+ :usage "[OPTION]... TARGET LINK_NAME
+ or: ln [OPTION]... TARGET... DIRECTORY
+Create a link to the specified TARGET with LINK_NAME. If there is more
+than one TARGET, the last argument must be a directory; create links in
+DIRECTORY to each TARGET. Create hard links by default, symbolic links
with `--symbolic'. When creating hard links, each TARGET must exist.")
(let ((no-dereference t))
(eshell-mvcpln-template "ln" "linking"
@@ -940,7 +940,7 @@ external command."
"display data only this many levels of data")
(?h "human-readable" 1024 human-readable
"print sizes in human readable format")
- (?H "is" 1000 human-readable
+ (?H "si" 1000 human-readable
"likewise, but use powers of 1000 not 1024")
(?k "kilobytes" 1024 block-size
"like --block-size 1024")
diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el
index 97ddac58629..78cf28d785a 100644
--- a/lisp/eshell/esh-arg.el
+++ b/lisp/eshell/esh-arg.el
@@ -285,7 +285,7 @@ QUOTED is passed to `eshell-concat' (which see) and, if
non-nil,
allows values to be converted to numbers where appropriate.
ARGS should be a list of lists of arguments, such as that
-produced by `eshell-prepare-slice'. \"Adjacent\" values of
+produced by `eshell-prepare-splice'. \"Adjacent\" values of
consecutive arguments will be passed to `eshell-concat'. For
example, if ARGS is
diff --git a/lisp/eshell/esh-ext.el b/lisp/eshell/esh-ext.el
index dc2b93e574b..44861c222b8 100644
--- a/lisp/eshell/esh-ext.el
+++ b/lisp/eshell/esh-ext.el
@@ -253,10 +253,10 @@ An external command simply means external to Emacs."
"Add a set of paths to PATH."
(eshell-eval-using-options
"addpath" args
- '((?b "begin" nil prepend "add path element at beginning")
+ '((?b "begin" nil prepend "add to beginning of $PATH")
(?h "help" nil nil "display this usage message")
- :usage "[-b] PATH
-Adds the given PATH to $PATH.")
+ :usage "[-b] DIR...
+Adds the given DIR to $PATH.")
(let ((path (eshell-get-path t)))
(if args
(progn
diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el
index fd279f61673..b15f99a0359 100644
--- a/lisp/eshell/esh-mode.el
+++ b/lisp/eshell/esh-mode.el
@@ -290,7 +290,7 @@ non-interactive sessions, such as when using
`eshell-command'.")
"C-e" #'eshell-show-maximum-output
"C-f" #'eshell-forward-argument
"C-m" #'eshell-copy-old-input
- "C-o" #'eshell-kill-output
+ "C-o" #'eshell-delete-output
"C-r" #'eshell-show-output
"C-t" #'eshell-truncate-buffer
"C-u" #'eshell-kill-input
@@ -832,15 +832,23 @@ This function should be in the list
`eshell-output-filter-functions'."
eshell-last-output-start
eshell-last-output-end))
-(defun eshell-kill-output ()
- "Kill all output from interpreter since last input.
-Does not delete the prompt."
- (interactive)
+(defun eshell-delete-output (&optional kill)
+ "Delete all output from interpreter since last input.
+If KILL is non-nil (interactively, the prefix), save the killed text in
+the kill ring.
+
+This command does not delete the prompt."
+ (interactive "P")
(save-excursion
(goto-char (eshell-beginning-of-output))
(insert "*** output flushed ***\n")
+ (when kill
+ (copy-region-as-kill (point) (eshell-end-of-output)))
(delete-region (point) (eshell-end-of-output))))
+(define-obsolete-function-alias 'eshell-kill-output
+ #'eshell-delete-output "30.1")
+
(defun eshell-show-output (&optional arg)
"Display start of this batch of interpreter output at top of window.
Sets mark to the value of point when this command is run.
diff --git a/lisp/eshell/esh-opt.el b/lisp/eshell/esh-opt.el
index d01e3569d57..e6f5fc9629a 100644
--- a/lisp/eshell/esh-opt.el
+++ b/lisp/eshell/esh-opt.el
@@ -100,29 +100,37 @@ the new process for its value.
Lastly, any remaining arguments will be available in the locally
let-bound variable `args'."
(declare (debug (form form sexp body)))
- `(let* ((temp-args
- ,(if (memq ':preserve-args (cadr options))
- (list 'copy-tree macro-args)
- (list 'eshell-stringify-list
- (list 'flatten-tree macro-args))))
- (processed-args (eshell--do-opts ,name ,options temp-args
,macro-args))
- ,@(delete-dups
- (delq nil (mapcar (lambda (opt)
- (and (listp opt) (nth 3 opt)
- `(,(nth 3 opt) (pop processed-args))))
- ;; `options' is of the form (quote OPTS).
- (cadr options))))
- (args processed-args))
- ;; Silence unused lexical variable warning if body does not use `args'.
- (ignore args)
- ,@body-forms))
+ (let ((option-syms (eshell--get-option-symbols
+ ;; `options' is of the form (quote OPTS).
+ (cadr options))))
+ `(let* ((temp-args
+ ,(if (memq ':preserve-args (cadr options))
+ (list 'copy-tree macro-args)
+ (list 'eshell-stringify-list
+ (list 'flatten-tree macro-args))))
+ (args (eshell--do-opts ,name temp-args ,macro-args
+ ,options ',option-syms))
+ ;; Bind all the option variables. When done, `args' will
+ ;; contain any remaining positional arguments.
+ ,@(mapcar (lambda (sym) `(,sym (pop args))) option-syms))
+ ;; Silence unused lexical variable warning if body does not use `args'.
+ (ignore args)
+ ,@body-forms)))
;;; Internal Functions:
;; Documented part of the interface; see eshell-eval-using-options.
(defvar eshell--args)
-(defun eshell--do-opts (name options args orig-args)
+(defun eshell--get-option-symbols (options)
+ "Get a list of symbols for the specified OPTIONS.
+OPTIONS is a list of command-line options from
+`eshell-eval-using-options' (which see)."
+ (delete-dups
+ (delq nil (mapcar (lambda (opt) (and (listp opt) (nth 3 opt)))
+ options))))
+
+(defun eshell--do-opts (name args orig-args options option-syms)
"Helper function for `eshell-eval-using-options'.
This code doesn't really need to be macro expanded everywhere."
(require 'esh-ext)
@@ -134,7 +142,8 @@ This code doesn't really need to be macro expanded
everywhere."
(if (and (= (length args) 0)
(memq ':show-usage options))
(eshell-show-usage name options)
- (setq args (eshell--process-args name args options))
+ (setq args (eshell--process-args name args options
+ option-syms))
nil))))
(when usage-msg
(user-error "%s" usage-msg))))))
@@ -269,16 +278,13 @@ triggered to say that the switch is unrecognized."
"%s: unrecognized option --%s")
name (car switch)))))))
-(defun eshell--process-args (name args options)
- "Process the given ARGS using OPTIONS."
- (let* ((seen ())
- (opt-vals (delq nil (mapcar (lambda (opt)
- (when (listp opt)
- (let ((sym (nth 3 opt)))
- (when (and sym (not (memq sym
seen)))
- (push sym seen)
- (list sym)))))
- options)))
+(defun eshell--process-args (name args options option-syms)
+ "Process the given ARGS for the command NAME using OPTIONS.
+OPTION-SYMS is a list of symbols that will hold the processed arguments.
+
+Return a list of values corresponding to each element in OPTION-SYMS,
+followed by any additional positional arguments."
+ (let* ((opt-vals (mapcar #'list option-syms))
(ai 0) arg
(eshell--args args)
(pos-argument-found nil))
diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el
index 537bc4b0641..02b5c785625 100644
--- a/lisp/eshell/esh-var.el
+++ b/lisp/eshell/esh-var.el
@@ -433,7 +433,7 @@ the values of nil for each."
(?h "help" nil nil "show this usage screen")
:external "env"
:parse-leading-options-only
- :usage "[NAME=VALUE]... [COMMAND [ARG]...]")
+ :usage "[NAME=VALUE]... [COMMAND]...")
(if args
(or (eshell-parse-local-variables args)
(eshell-named-command (car args) (cdr args)))
diff --git a/lisp/faces.el b/lisp/faces.el
index d5120f42b92..c3a54a08a3d 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -651,11 +651,11 @@ Optional argument INHERIT is passed to `face-attribute'."
If FACE is a face-alias, get the documentation for the target face."
(let ((alias (get face 'face-alias)))
(if alias
- (let ((doc (get alias 'face-documentation)))
+ (let ((doc (documentation-property alias 'face-documentation)))
(format "%s is an alias for the face `%s'.%s" face alias
(if doc (format "\n%s" doc)
"")))
- (get face 'face-documentation))))
+ (documentation-property face 'face-documentation))))
(defun set-face-documentation (face string)
diff --git a/lisp/ffap.el b/lisp/ffap.el
index 3492dcbf17a..5383f743878 100644
--- a/lisp/ffap.el
+++ b/lisp/ffap.el
@@ -1098,12 +1098,12 @@ Suppose the cursor is somewhere that might be near end
of file,
the guessing would position point before punctuation (like comma)
after the file extension:
- C:\temp\file.log, which contain ....
+ C:\\temp\\file.log, which contain ....
=============================== (before)
---------------- (after)
- C:\temp\file.log on Windows or /tmp/file.log on Unix
+ C:\\temp\\file.log on Windows or /tmp/file.log on Unix
=============================== (before)
---------------- (after)
diff --git a/lisp/files.el b/lisp/files.el
index 9c8914bfc50..524385edc84 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -2747,6 +2747,10 @@ Fifth arg NOMODES non-nil means don't alter the file's
modes.
Finishes by calling the functions in `find-file-hook'
unless NOMODES is non-nil."
(setq buffer-read-only (not (file-writable-p buffer-file-name)))
+ ;; The above is sufficiently like turning on read-only-mode, so run
+ ;; the mode hook here by hand.
+ (if buffer-read-only
+ (run-hooks 'read-only-mode-hook))
(if noninteractive
nil
(let* (not-serious
@@ -3270,7 +3274,16 @@ and `inhibit-local-variables-suffixes'. If
;; Optional group 1: env(1) invocation.
"\\("
"[^ \t\n]*/bin/env[ \t]*"
- "\\(?:-S[ \t]*\\|--split-string\\(?:=\\|[ \t]*\\)\\)?"
+ ;; Within group 1: possible -S/--split-string and environment
+ ;; adjustments.
+ "\\(?:"
+ ;; -S/--split-string
+ "\\(?:-[0a-z]*S[ \t]*\\|--split-string=\\)"
+ ;; More env arguments.
+ "\\(?:-[^ \t\n]+[ \t]+\\)*"
+ ;; Interpreter environment modifications.
+ "\\(?:[^ \t\n]+=[^ \t\n]*[ \t]+\\)*"
+ "\\)?"
"\\)?"
;; Group 2: interpreter.
"\\([^ \t\n]+\\)"))
@@ -3754,7 +3767,8 @@ function is allowed to change the contents of this alist.
This hook is called only if there is at least one file-local
variable to set.")
-(defvar permanently-enabled-local-variables '(lexical-binding)
+(defvar permanently-enabled-local-variables
+ '(lexical-binding read-symbol-shorthands)
"A list of file-local variables that are always enabled.
This overrides any `enable-local-variables' setting.")
@@ -4190,6 +4204,13 @@ major-mode."
;; to use 'thisbuf's name in the
;; warning message.
(or (buffer-file-name thisbuf) ""))))))
+ ((eq var 'read-symbol-shorthands)
+ ;; Sort automatically by shorthand length
+ ;; in descending order.
+ (setq val (sort val
+ (lambda (sh1 sh2) (> (length (car
sh1))
+ (length (car
sh2))))))
+ (push (cons 'read-symbol-shorthands val) result))
((and (eq var 'mode) handle-mode))
(t
(ignore-errors
diff --git a/lisp/filesets.el b/lisp/filesets.el
index 4e2de8fed1b..68133ba2255 100644
--- a/lisp/filesets.el
+++ b/lisp/filesets.el
@@ -161,18 +161,9 @@ COND-FN takes one argument: the current element."
(define-obsolete-function-alias 'filesets-member #'cl-member "28.1")
(define-obsolete-function-alias 'filesets-sublist #'seq-subseq "28.1")
-(defun filesets-select-command (cmd-list)
- "Select one command from CMD-LIST -- a string with space separated names."
- (let ((this (shell-command-to-string
- (format "which --skip-alias %s 2> %s | head -n 1"
- cmd-list null-device))))
- (if (equal this "")
- nil
- (file-name-nondirectory (substring this 0 (- (length this) 1))))))
-
(defun filesets-which-command (cmd)
"Call \"which CMD\"."
- (shell-command-to-string (format "which %s" cmd)))
+ (shell-command-to-string (format "which %s" (shell-quote-argument cmd))))
(defun filesets-which-command-p (cmd)
"Call \"which CMD\" and return non-nil if the command was found."
@@ -547,16 +538,6 @@ the filename."
(defcustom filesets-external-viewers
(let
- ;; ((ps-cmd (or (and (boundp 'my-ps-viewer) my-ps-viewer)
- ;; (filesets-select-command "ggv gv")))
- ;; (pdf-cmd (or (and (boundp 'my-ps-viewer) my-pdf-viewer)
- ;; (filesets-select-command "xpdf acroread")))
- ;; (dvi-cmd (or (and (boundp 'my-ps-viewer) my-dvi-viewer)
- ;; (filesets-select-command "xdvi tkdvi")))
- ;; (doc-cmd (or (and (boundp 'my-ps-viewer) my-doc-viewer)
- ;; (filesets-select-command "antiword")))
- ;; (pic-cmd (or (and (boundp 'my-ps-viewer) my-pic-viewer)
- ;; (filesets-select-command "gqview ee display"))))
((ps-cmd "ggv")
(pdf-cmd "xpdf")
(dvi-cmd "xdvi")
@@ -1084,10 +1065,6 @@ Return full path if FULL-FLAG is non-nil."
(t
(error "Filesets: %s does not exist" dir))))
-(defun filesets-quote (txt)
- "Return TXT in quotes."
- (concat "\"" txt "\""))
-
(defun filesets-get-selection ()
"Get the text between mark and point -- i.e. the selection or region."
(let ((m (mark))
@@ -1098,7 +1075,7 @@ Return full path if FULL-FLAG is non-nil."
(defun filesets-get-quoted-selection ()
"Return the currently selected text in quotes."
- (filesets-quote (filesets-get-selection)))
+ (shell-quote-argument (filesets-get-selection)))
(defun filesets-get-shortcut (n)
"Create menu shortcuts based on number N."
@@ -1245,12 +1222,13 @@ Use the viewer defined in EV-ENTRY (a valid element of
(if fmt
(mapconcat
(lambda (this)
- (if (stringp this) (format this file)
- (format "%S" (if (functionp this)
- (funcall this)
- this))))
+ (if (stringp this)
+ (format this (shell-quote-argument file))
+ (shell-quote-argument (if (functionp this)
+ (funcall this)
+ this))))
fmt "")
- (format "%S" file))))
+ (shell-quote-argument file))))
(output
(cond
((and (functionp vwr) co-flag)
@@ -1259,7 +1237,7 @@ Use the viewer defined in EV-ENTRY (a valid element of
(funcall vwr file)
nil)
(co-flag
- (shell-command-to-string (format "%s %s" vwr args)))
+ (shell-command-to-string (format "%s %s" vwr args)))
(t
(shell-command (format "%s %s&" vwr args))
nil))))
@@ -2483,11 +2461,15 @@ Set up hooks, load the cache file -- if existing -- and
build the menu."
(setq filesets-menu-use-cached-flag t)))
(filesets-build-menu)))
+;;; obsolete
+
(defun filesets-error (_class &rest args)
"`error' wrapper."
(declare (obsolete error "28.1"))
(error "%s" (mapconcat #'identity args " ")))
+(define-obsolete-function-alias 'filesets-quote #'shell-quote-argument "30.1")
+
(provide 'filesets)
;;; filesets.el ends here
diff --git a/lisp/forms.el b/lisp/forms.el
index 009667af273..3a3160a0c8b 100644
--- a/lisp/forms.el
+++ b/lisp/forms.el
@@ -343,7 +343,7 @@ suitable for forms processing.")
(defvar forms-write-file-filter nil
"The name of a function that is called before writing the data file.
-This can be used to undo the effects of `form-read-file-filter'.")
+This can be used to undo the effects of `forms-read-file-filter'.")
(defvar forms-new-record-filter nil
"The name of a function that is called when a new record is created.")
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index 3ee93031119..1726b806913 100644
--- a/lisp/gnus/gnus-agent.el
+++ b/lisp/gnus/gnus-agent.el
@@ -2910,13 +2910,9 @@ The following commands are available:
(car func)
(gnus-byte-compile `(lambda () ,func)))))
-(defun gnus-agent-true ()
- "Return t."
- t)
+(defalias 'gnus-agent-true #'always)
-(defun gnus-agent-false ()
- "Return nil."
- nil)
+(defalias 'gnus-agent-false #'ignore)
(defun gnus-category-make-function-1 (predicate)
"Make a function from PREDICATE."
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el
index c3c5eab7d89..9f313108089 100644
--- a/lisp/gnus/gnus-art.el
+++ b/lisp/gnus/gnus-art.el
@@ -694,7 +694,7 @@ used as possible file names."
(defcustom gnus-page-delimiter "^\^L"
"Regexp describing what to use as article page delimiters.
-The default value is \"^\^L\", which is a form linefeed at the
+The default value is \"^\\^L\", which is a form linefeed at the
beginning of a line."
:type 'regexp
:group 'gnus-article-various)
diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el
index 48c1aef968b..f33c5f7f2e5 100644
--- a/lisp/gnus/gnus-dired.el
+++ b/lisp/gnus/gnus-dired.el
@@ -111,6 +111,12 @@ See `mail-user-agent' for more information."
(autoload 'gnus-completing-read "gnus-util")
+(defcustom gnus-dired-attach-at-end t
+ "Non-nil means that files should be attached at the end of a buffer."
+ :group 'mail ;; dired?
+ :version "30.1"
+ :type 'boolean)
+
;; Method to attach files to a mail composition.
(defun gnus-dired-attach (files-to-attach)
"Attach dired's marked files to a gnus message composition.
@@ -161,7 +167,8 @@ filenames."
;; set buffer to destination buffer, and attach files
(set-buffer destination)
- (goto-char (point-max)) ;attach at end of buffer
+ (when gnus-dired-attach-at-end
+ (goto-char (point-max))) ;attach at end of buffer
(while files-to-attach
(mml-attach-file (car files-to-attach)
(or (mm-default-file-type (car files-to-attach))
diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el
index fdf97e1aabd..b18ede58fbf 100644
--- a/lisp/gnus/gnus-msg.el
+++ b/lisp/gnus/gnus-msg.el
@@ -1189,12 +1189,12 @@ Uses the process/prefix convention.
The reply will include all From/Cc headers from the original
messages as the To/Cc headers.
-If prefix argument YANK is non-nil, the original article(s) will
+If prefix argument YANK is non-nil, the original article will
be yanked automatically."
(interactive (list (and current-prefix-arg
(gnus-summary-work-articles 1)))
gnus-summary-mode)
- (gnus-summary-reply yank t (gnus-summary-work-articles yank)))
+ (gnus-summary-reply yank t (gnus-summary-work-articles current-prefix-arg)))
(defun gnus-summary-very-wide-reply-with-original (n)
"Start composing a very wide reply mail a set of messages.
diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el
index bd19e7d7cd7..479b7496cf1 100644
--- a/lisp/gnus/gnus-score.el
+++ b/lisp/gnus/gnus-score.el
@@ -893,9 +893,14 @@ If optional argument `EXTRA' is non-nil, it's a
non-standard overview header."
(t "permanent"))
header
(if (< score 0) "lower" "raise"))
- (if (numberp match)
- (int-to-string match)
- match))))
+ (cond ((numberp match) (int-to-string match))
+ ((string= header "date")
+ (int-to-string
+ (-
+ (/ (car (time-convert (current-time) 1)) 86400)
+ (/ (car (time-convert (gnus-date-get-time match)
1))
+ 86400))))
+ (t match)))))
;; If this is an integer comparison, we transform from string to int.
(if (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el
index b5aa0b02d34..0b0a9bbfc1d 100644
--- a/lisp/gnus/gnus-util.el
+++ b/lisp/gnus/gnus-util.el
@@ -1113,8 +1113,7 @@ sure of changing the value of `foo'."
(setq gnus-info-buffer (current-buffer))
(gnus-configure-windows 'info)))
-(defun gnus-not-ignore (&rest _args)
- t)
+(defalias 'gnus-not-ignore #'always)
(defvar gnus-directory-sep-char-regexp "/"
"The regexp of directory separator character.
diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el
index 99833e4eeca..dab66b60205 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -309,12 +309,31 @@ be set in `.emacs' instead."
:group 'gnus-start
:type 'boolean)
+(defcustom gnus-mode-line-logo
+ '((:type svg :file "gnus-pointer.svg" :ascent center)
+ (:type xpm :file "gnus-pointer.xpm" :ascent center)
+ (:type xbm :file "gnus-pointer.xbm" :ascent center))
+ "Image spec for the Gnus logo to be displayed in mode-line.
+
+If non-nil, it should be a list of image specifications to be passed
+as the first argument to `find-image', which see. Then, if the display
+is capable of showing images, the Gnus logo will be displayed as part of
+the buffer-identification in the mode-line of Gnus-buffers.
+
+If nil, there will be no Gnus logo in the mode-line."
+ :group 'gnus-visual
+ :type '(choice
+ (repeat :tag "List of Gnus logo image specifications" (plist))
+ (const :tag "Don't display Gnus logo" nil))
+ :version "30.1")
+
(defun gnus-mode-line-buffer-identification (line)
(let* ((str (car-safe line))
(str (if (stringp str)
(car (propertized-buffer-identification str))
str)))
- (if (or (not (fboundp 'find-image))
+ (if (or (not gnus-mode-line-logo)
+ (not (fboundp 'find-image))
(not (display-graphic-p))
(not (stringp str))
(not (string-match "^Gnus:" str)))
@@ -325,14 +344,7 @@ be set in `.emacs' instead."
(add-text-properties
0 5
(list 'display
- (find-image
- '((:type svg :file "gnus-pointer.svg"
- :ascent center)
- (:type xpm :file "gnus-pointer.xpm"
- :ascent center)
- (:type xbm :file "gnus-pointer.xbm"
- :ascent center))
- t)
+ (find-image gnus-mode-line-logo t)
'help-echo (if gnus-emacs-version
(format
"This is %s, %s."
diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el
index 97821894b48..ea679759f3e 100644
--- a/lisp/gnus/nnheader.el
+++ b/lisp/gnus/nnheader.el
@@ -1016,7 +1016,7 @@ See `find-file-noselect' for the arguments."
(nnheader-skeleton-replace from to t))
(defun nnheader-strip-cr ()
- "Strip all \r's from the current buffer."
+ "Strip all \\r's from the current buffer."
(nnheader-skeleton-replace "\r"))
(define-obsolete-function-alias 'nnheader-cancel-timer 'cancel-timer "27.1")
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 99642d08bbd..15d87f9925c 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -1799,9 +1799,8 @@ If FRAME is omitted or nil, use the selected frame."
alias)
""))))
(insert "\nDocumentation:\n"
- (substitute-command-keys
- (or (face-documentation face)
- "Not documented as a face."))
+ (or (face-documentation face)
+ "Not documented as a face.")
"\n\n"))
(with-current-buffer standard-output
(save-excursion
@@ -2134,6 +2133,12 @@ keymap value."
(when used-gentemp
(makunbound keymap))))
+(defcustom describe-mode-outline t
+ "Non-nil enables outlines in the output buffer of `describe-mode'."
+ :type 'boolean
+ :group 'help
+ :version "30.1")
+
;;;###autoload
(defun describe-mode (&optional buffer)
"Display documentation of current major mode and minor modes.
@@ -2146,7 +2151,10 @@ variable \(listed in `minor-mode-alist') must also be a
function
whose documentation describes the minor mode.
If called from Lisp with a non-nil BUFFER argument, display
-documentation for the major and minor modes of that buffer."
+documentation for the major and minor modes of that buffer.
+
+When `describe-mode-outline' is non-nil, Outline minor mode
+is enabled in the Help buffer."
(interactive "@")
(unless buffer
(setq buffer (current-buffer)))
@@ -2160,13 +2168,20 @@ documentation for the major and minor modes of that
buffer."
(with-current-buffer (help-buffer)
;; Add the local minor modes at the start.
(when local-minors
- (insert (format "Minor mode%s enabled in this buffer:"
- (if (length> local-minors 1)
- "s" "")))
+ (unless describe-mode-outline
+ (insert (format "Minor mode%s enabled in this buffer:"
+ (if (length> local-minors 1)
+ "s" ""))))
(describe-mode--minor-modes local-minors))
;; Document the major mode.
(let ((major (buffer-local-value 'major-mode buffer)))
+ (when describe-mode-outline
+ (goto-char (point-min))
+ (put-text-property
+ (point) (progn (insert (format "Major mode %S" major)) (point))
+ 'outline-level 1)
+ (insert "\n\n"))
(insert "The major mode is "
(buttonize
(propertize (format-mode-line
@@ -2190,36 +2205,56 @@ documentation for the major and minor modes of that
buffer."
;; Insert the global minor modes after the major mode.
(when global-minor-modes
- (insert (format "Global minor mode%s enabled:"
- (if (length> global-minor-modes 1)
- "s" "")))
- (describe-mode--minor-modes global-minor-modes)
- (when (re-search-forward "^\f")
- (beginning-of-line)
- (ensure-empty-lines 1)))
+ (unless describe-mode-outline
+ (insert (format "Global minor mode%s enabled:"
+ (if (length> global-minor-modes 1)
+ "s" ""))))
+ (describe-mode--minor-modes global-minor-modes t)
+ (unless describe-mode-outline
+ (when (re-search-forward "^\f")
+ (beginning-of-line)
+ (ensure-empty-lines 1))))
+
+ (when describe-mode-outline
+ (setq-local outline-search-function #'outline-search-level)
+ (setq-local outline-level (lambda () 1))
+ (setq-local outline-minor-mode-cycle t
+ outline-minor-mode-highlight t
+ outline-minor-mode-use-buttons 'insert)
+ (outline-minor-mode 1))
+
;; For the sake of IELM and maybe others
nil)))))
-(defun describe-mode--minor-modes (modes)
+(defun describe-mode--minor-modes (modes &optional global)
(dolist (mode (seq-sort #'string< modes))
(let ((pretty-minor-mode
(capitalize
(replace-regexp-in-string
"\\(\\(-minor\\)?-mode\\)?\\'" ""
(symbol-name mode)))))
- (insert
- " "
- (buttonize
- pretty-minor-mode
- (lambda (mode)
- (goto-char (point-min))
- (text-property-search-forward
- 'help-minor-mode mode t)
- (beginning-of-line))
- mode))
+ (if (not describe-mode-outline)
+ (insert
+ " "
+ (buttonize
+ pretty-minor-mode
+ (lambda (mode)
+ (goto-char (point-min))
+ (text-property-search-forward
+ 'help-minor-mode mode t)
+ (beginning-of-line))
+ mode))
+ (goto-char (point-max))
+ (put-text-property
+ (point) (progn (insert (if global "Global" "Local")
+ (format " minor mode %S" mode))
+ (point))
+ 'outline-level 1)
+ (insert "\n\n"))
(save-excursion
- (goto-char (point-max))
- (insert "\n\n\f\n")
+ (unless describe-mode-outline
+ (goto-char (point-max))
+ (insert "\n\n\f\n"))
;; Document the minor modes fully.
(insert (buttonize
(propertize pretty-minor-mode 'help-minor-mode mode)
@@ -2233,11 +2268,14 @@ documentation for the major and minor modes of that
buffer."
(format "indicator%s"
indicator)))))
(insert (or (help-split-fundoc (documentation mode) nil 'doc)
- "No docstring")))))
- (forward-line -1)
- (fill-paragraph nil)
- (forward-paragraph 1)
- (ensure-empty-lines 1))
+ "No docstring"))
+ (when describe-mode-outline
+ (insert "\n\n")))))
+ (unless describe-mode-outline
+ (forward-line -1)
+ (fill-paragraph nil)
+ (forward-paragraph 1)
+ (ensure-empty-lines 1)))
(defun help-fns--list-local-commands ()
(let ((functions nil))
diff --git a/lisp/help-mode.el b/lisp/help-mode.el
index 9c405efeee5..f9ec8a5cc2b 100644
--- a/lisp/help-mode.el
+++ b/lisp/help-mode.el
@@ -501,7 +501,17 @@ restore it properly when going back."
;; Disable `outline-minor-mode' in a reused Help buffer
;; created by `describe-bindings' that enables this mode.
(when (bound-and-true-p outline-minor-mode)
- (outline-minor-mode -1))
+ (outline-minor-mode -1)
+ (mapc #'kill-local-variable
+ '(outline-search-function
+ outline-regexp
+ outline-heading-end-regexp
+ outline-level
+ outline-minor-mode-cycle
+ outline-minor-mode-highlight
+ outline-minor-mode-use-buttons
+ outline-default-state
+ outline-default-rules)))
(when help-xref-stack-item
(push (cons (point) help-xref-stack-item) help-xref-stack)
(setq help-xref-forward-stack nil))
diff --git a/lisp/help.el b/lisp/help.el
index 72a4f8a800d..c6a1e3c6bd9 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -151,7 +151,7 @@ buffer.")
("Mark & Kill"
(set-mark-command . "mark")
(kill-line . "kill line")
- (kill-ring-save . "kill region")
+ (kill-region . "kill region")
(yank . "yank")
(exchange-point-and-mark . "swap"))
("Projects"
@@ -165,7 +165,15 @@ buffer.")
(isearch-forward . "search")
(isearch-backward . "reverse search")
(query-replace . "search & replace")
- (fill-paragraph . "reformat"))))
+ (fill-paragraph . "reformat")))
+ "Data structure for `help-quick'.
+Value should be a list of elements, each element should of the form
+
+ (GROUP-NAME (COMMAND . DESCRIPTION) (COMMAND . DESCRIPTION)...)
+
+where GROUP-NAME is the name of the group of the commands,
+COMMAND is the symbol of a command and DESCRIPTION is its short
+description, 10 to 15 char5acters at most.")
(declare-function prop-match-value "text-property-search" (match))
@@ -2253,6 +2261,27 @@ The `temp-buffer-window-setup-hook' hook is called."
(with-output-to-temp-buffer " *Char Help*"
(princ msg)))))
+(defun help--append-keystrokes-help (str)
+ (let* ((keys (this-single-command-keys))
+ (bindings (delete nil
+ (mapcar (lambda (map) (lookup-key map keys t))
+ (current-active-maps t)))))
+ (catch 'res
+ (dolist (val help-event-list)
+ (let ((key (vector (if (eql val 'help)
+ help-char
+ val))))
+ (unless (seq-find (lambda (map) (and (keymapp map) (lookup-key map
key)))
+ bindings)
+ (throw 'res
+ (concat
+ str
+ (substitute-command-keys
+ (format
+ " (\\`%s' for help)"
+ (key-description key))))))))
+ str)))
+
(defun help--docstring-quote (string)
"Return a doc string that represents STRING.
diff --git a/lisp/ielm.el b/lisp/ielm.el
index 777aebb70cf..e583e0fe32c 100644
--- a/lisp/ielm.el
+++ b/lisp/ielm.el
@@ -110,6 +110,13 @@ This gives more frame width for large indented sexps, and
allows functions
such as `edebug-defun' to work with such inputs."
:type 'boolean)
+(defcustom ielm-history-file-name
+ (locate-user-emacs-file "ielm-history.eld")
+ "If non-nil, name of the file to read/write IELM input history."
+ :type '(choice (const :tag "Disable input history" nil)
+ file)
+ :version "30.1")
+
(defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook)
(defcustom ielm-mode-hook nil
"Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started."
@@ -503,6 +510,17 @@ behavior of the indirect buffer."
(funcall pp-default-function beg end)
end))
+;;; Input history
+
+(defvar ielm--exit nil
+ "Function to call when Emacs is killed.")
+
+(defun ielm--input-history-writer (buf)
+ "Return a function writing IELM input history to BUF."
+ (lambda ()
+ (with-current-buffer buf
+ (comint-write-input-ring))))
+
;;; Major mode
(define-derived-mode inferior-emacs-lisp-mode comint-mode "IELM"
@@ -605,6 +623,17 @@ Customized bindings may be defined in `ielm-map', which
currently contains:
#'ielm-indirect-setup-hook 'append t)
(setq comint-indirect-setup-function #'emacs-lisp-mode)
+ ;; Input history
+ (setq-local comint-input-ring-file-name ielm-history-file-name)
+ (setq-local ielm--exit (ielm--input-history-writer (current-buffer)))
+ (setq-local kill-buffer-hook
+ (lambda ()
+ (funcall ielm--exit)
+ (remove-hook 'kill-emacs-hook ielm--exit)))
+ (unless noninteractive
+ (add-hook 'kill-emacs-hook ielm--exit))
+ (comint-read-input-ring t)
+
;; A dummy process to keep comint happy. It will never get any input
(unless (comint-check-proc (current-buffer))
;; Was cat, but on non-Unix platforms that might not exist, so
diff --git a/lisp/image.el b/lisp/image.el
index 73801f88d1e..2ebce59a98c 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -759,21 +759,25 @@ BUFFER nil or omitted means use the current buffer."
;;;###autoload
(defun find-image (specs &optional cache)
- "Find an image, choosing one of a list of image specifications.
+ "Find an image that satisfies one of a list of image specifications.
SPECS is a list of image specifications.
-Each image specification in SPECS is a property list. The contents of
-a specification are image type dependent. All specifications must at
-least contain either the property `:file FILE' or `:data DATA',
-where FILE is the file to load the image from, and DATA is a string
-containing the actual image data. If the property `:type TYPE' is
-omitted or nil, try to determine the image type from its first few
+Each image specification in SPECS is a property list. The
+contents of a specification are image type dependent; see the
+info node `(elisp)Image Descriptors' for details. All specifications
+must at least contain either the property `:file FILE' or `:data DATA',
+where FILE is the file from which to load the image, and DATA is a
+string containing the actual image data. If the property `:type TYPE'
+is omitted or nil, try to determine the image type from its first few
bytes of image data. If that doesn't work, and the property `:file
-FILE' provide a file name, use its file extension as image type.
-If `:type TYPE' is provided, it must match the actual type
-determined for FILE or DATA by `create-image'. Return nil if no
-specification is satisfied.
+FILE' provide a file name, use its file extension as idication of the
+image type. If `:type TYPE' is provided, it must match the actual type
+determined for FILE or DATA by `create-image'.
+
+The function returns the image specification for the first specification
+in the list whose TYPE is supported and FILE, if specified, exists. It
+returns nil if no specification in the list can be satisfied.
If CACHE is non-nil, results are cached and returned on subsequent calls.
diff --git a/lisp/info.el b/lisp/info.el
index e91cc7b8e54..176bc9c0033 100644
--- a/lisp/info.el
+++ b/lisp/info.el
@@ -231,8 +231,9 @@ Each element of this list has the form (MANUALs . URL-SPEC).
MANUALs represents the name of one or more manuals. It can
either be a string or a list of strings. URL-SPEC can be a
string in which the substring \"%m\" will be expanded to the
-manual-name, \"%n\" to the node-name, and \"%e\" to the
-URL-encoded node-name (without a `.html' suffix). (The
+manual-name and \"%n\" to the node-name. \"%e\" will expand to
+the URL-encoded node-name, including the `.html' extension; in
+case of the Top node, it will expand to the empty string. (The
URL-encoding of the node-name mimics GNU Texinfo, as documented
at Info node `(texinfo)HTML Xref Node Name Expansion'.)
Alternatively, URL-SPEC can be a function which is given
@@ -499,6 +500,7 @@ or `Info-virtual-nodes'."
(".info.bz2" . ("bzip2" "-dc"))
(".info.xz" . "unxz")
(".info.zst" . ("zstd" "-dc"))
+ (".info.lz" . ("lzip" "-dc"))
(".info" . nil)
("-info.Z" . "uncompress")
("-info.Y" . "unyabba")
@@ -507,6 +509,7 @@ or `Info-virtual-nodes'."
("-info.z" . "gunzip")
("-info.xz" . "unxz")
("-info.zst" . ("zstd" "-dc"))
+ ("-info.lz" . ("lzip" "-dc"))
("-info" . nil)
("/index.Z" . "uncompress")
("/index.Y" . "unyabba")
@@ -515,6 +518,7 @@ or `Info-virtual-nodes'."
("/index.bz2" . ("bzip2" "-dc"))
("/index.xz" . "unxz")
("/index.zst" . ("zstd" "-dc"))
+ ("/index.lz" . ("lzip" "-dc"))
("/index" . nil)
(".Z" . "uncompress")
(".Y" . "unyabba")
@@ -523,6 +527,7 @@ or `Info-virtual-nodes'."
(".bz2" . ("bzip2" "-dc"))
(".xz" . "unxz")
(".zst" . ("zstd" "-dc"))
+ (".lz" . ("lzip" "-dc"))
("" . nil)))
"List of file name suffixes and associated decoding commands.
Each entry should be (SUFFIX . STRING); the file is given to
@@ -1924,18 +1929,20 @@ NODE should be a string of the form \"(manual)Node\"."
;; (info "(texinfo) HTML Xref Node Name Expansion")
(if (equal node "Top")
""
- (url-hexify-string
- (string-replace " " "-"
- (mapconcat
- (lambda (ch)
- (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^-
- (<= 33 ch 47) ; !"#$%&'()*+,-./
- (<= 58 ch 64) ; :;<=>?@
- (<= 91 ch 96) ; [\]_`
- (<= 123 ch 127)) ; {|}~ DEL
- (format "_00%x" ch)
- (char-to-string ch)))
- node ""))))))
+ (concat
+ (url-hexify-string
+ (string-replace " " "-"
+ (mapconcat
+ (lambda (ch)
+ (if (or (< ch 32) ; ^@^A-^Z^[^\^]^^^-
+ (<= 33 ch 47) ; !"#$%&'()*+,-./
+ (<= 58 ch 64) ; :;<=>?@
+ (<= 91 ch 96) ; [\]_`
+ (<= 123 ch 127)) ; {|}~ DEL
+ (format "_00%x" ch)
+ (char-to-string ch)))
+ node "")))
+ ".html"))))
(cond
((stringp url-spec)
(format-spec url-spec
diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el
index c4706e061e3..42584f6548c 100644
--- a/lisp/international/titdic-cnv.el
+++ b/lisp/international/titdic-cnv.el
@@ -31,12 +31,12 @@
;; Convert cxterm dictionary (of TIT format) to quail-package.
;;
;; Usage (within Emacs):
-;; M-x titdic-convert<CR>CXTERM-DICTIONARY-NAME<CR>
+;; M-x tit-dic-convert<CR>CXTERM-DICTIONARY-NAME<CR>
;; Usage (from shell):
-;; % emacs -batch -l titdic-cnv -f batch-titdic-convert\
+;; % emacs -batch -l titdic-cnv -f batch-tit-dic-convert\
;; [-dir DIR] [DIR | FILE] ...
;;
-;; When you run titdic-convert within Emacs, you have a chance to
+;; When you run `tit-dic-convert' within Emacs, you have a chance to
;; modify arguments of `quail-define-package' before saving the
;; converted file. For instance, you are likely to modify TITLE,
;; DOCSTRING, and KEY-BINDINGS.
@@ -90,7 +90,8 @@
;; \<quail-translation-docstring> is replaced by a description about
;; how to select a translation from a list of candidates.
-(defvar quail-cxterm-package-ext-info
+(define-obsolete-variable-alias 'quail-cxterm-package-ext-info
'tit-quail-cxterm-package-ext-info "30.1")
+(defvar tit-quail-cxterm-package-ext-info
'(("chinese-4corner" "四角")
("chinese-array30" "３０")
("chinese-ccdospy" "缩拼"
@@ -277,7 +278,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲,
4:去聲,
(tit-moveleft ",<")
(tit-keyprompt nil))
- (generate-lisp-file-heading filename 'titdic-convert :code nil)
+ (generate-lisp-file-heading filename 'tit-dic-convert :code nil)
(princ ";; Quail package `")
(princ package)
(princ "\n")
@@ -354,7 +355,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲,
4:去聲,
(princ "(quail-define-package ")
;; Args NAME, LANGUAGE, TITLE
- (let ((title (nth 1 (assoc package quail-cxterm-package-ext-info))))
+ (let ((title (nth 1 (assoc package tit-quail-cxterm-package-ext-info))))
(princ "\"")
(princ package)
(princ "\" \"")
@@ -383,7 +384,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲,
4:去聲,
(let ((doc (concat tit-prompt "\n"))
(comments (if tit-comments
(mapconcat #'identity (nreverse tit-comments) "\n")))
- (doc-ext (nth 2 (assoc package quail-cxterm-package-ext-info))))
+ (doc-ext (nth 2 (assoc package tit-quail-cxterm-package-ext-info))))
(if comments
(setq doc (concat doc "\n" comments "\n")))
(if doc-ext
@@ -476,6 +477,9 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲,
4:去聲,
;;;###autoload
(defun titdic-convert (filename &optional dirname)
+ (declare (obsolete tit-dic-convert "30.1"))
+ (tit-dic-convert filename dirname))
+(defun tit-dic-convert (filename &optional dirname)
"Convert a TIT dictionary of FILENAME into a Quail package.
Optional argument DIRNAME if specified is the directory name under which
the generated Quail package is saved."
@@ -531,21 +535,24 @@ the generated Quail package is saved."
;;;###autoload
(defun batch-titdic-convert (&optional force)
- "Run `titdic-convert' on the files remaining on the command line.
+ (declare (obsolete batch-tit-dic-convert "30.1"))
+ (batch-tit-dic-convert force))
+(defun batch-tit-dic-convert (&optional force)
+ "Run `tit-dic-convert' on the files remaining on the command line.
Use this from the command line, with `-batch';
it won't work in an interactive Emacs.
-For example, invoke \"emacs -batch -f batch-titdic-convert XXX.tit\" to
+For example, invoke \"emacs -batch -f batch-tit-dic-convert XXX.tit\" to
generate Quail package file \"xxx.el\" from TIT dictionary file \"XXX.tit\".
-To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"."
+To get complete usage, invoke \"emacs -batch -f batch-tit-dic-convert -h\"."
(defvar command-line-args-left) ; Avoid compiler warning.
(if (not noninteractive)
- (error "`batch-titdic-convert' should be used only with -batch"))
+ (error "`batch-tit-dic-convert' should be used only with -batch"))
(if (string= (car command-line-args-left) "-h")
(progn
(message "To convert XXX.tit and YYY.tit into xxx.el and yyy.el:")
- (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert
XXX.tit YYY.tit")
+ (message " %% emacs -batch -l titdic-cnv -f batch-tit-dic-convert
XXX.tit YYY.tit")
(message "To convert XXX.tit into DIR/xxx.el:")
- (message " %% emacs -batch -l titdic-cnv -f batch-titdic-convert -dir
DIR XXX.tit"))
+ (message " %% emacs -batch -l titdic-cnv -f batch-tit-dic-convert -dir
DIR XXX.tit"))
(let (targetdir filename files file)
(if (string= (car command-line-args-left) "-dir")
(progn
@@ -564,7 +571,7 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
(when (or force
(file-newer-than-file-p
file (tit-make-quail-package-file-name file targetdir)))
- (titdic-convert file targetdir))
+ (tit-dic-convert file targetdir))
(setq files (cdr files)))
(setq command-line-args-left (cdr command-line-args-left)))))
(kill-emacs 0))
@@ -583,10 +590,11 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
;; COPYRIGHT-NOTICE ;; Copyright notice of the source dictionary.
;; )
-(defvar quail-misc-package-ext-info
+(define-obsolete-variable-alias 'quail-misc-package-ext-info
'tit-quail-misc-package-ext-info "30.1")
+(defvar tit-quail-misc-package-ext-info
'(("chinese-b5-tsangchi" "倉B"
"cangjie-table.b5" big5 "tsang-b5.el"
- tsang-b5-converter
+ tit--tsang-b5-converter
"\
;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
;; #
@@ -596,7 +604,7 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
("chinese-b5-quick" "簡B"
"cangjie-table.b5" big5 "quick-b5.el"
- quick-b5-converter
+ tit--quick-b5-converter
"\
;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
;; #
@@ -606,7 +614,7 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
("chinese-cns-tsangchi" "倉C"
"cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el"
- tsang-cns-converter
+ tit--tsang-cns-converter
"\
;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
;; #
@@ -616,7 +624,7 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
("chinese-cns-quick" "簡C"
"cangjie-table.cns" iso-2022-cn-ext "quick-cns.el"
- quick-cns-converter
+ tit--quick-cns-converter
"\
;; # Copyright 2001 Christian Wittern <wittern@iis.sinica.edu.tw>
;; #
@@ -626,7 +634,7 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
("chinese-py" "拼G"
"pinyin.map" cn-gb-2312 "PY.el"
- py-converter
+ tit--py-converter
"\
;; \"pinyin.map\" is included in a free package called CCE. It is
;; available at: [link needs updating -- SK 2021-09-27]
@@ -654,7 +662,7 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
("chinese-ziranma" "自然"
"ziranma.cin" cn-gb-2312 "ZIRANMA.el"
- ziranma-converter
+ tit--ziranma-converter
"\
;; \"ziranma.cin\" is included in a free package called CCE. It is
;; available at: [link needs updating -- SK 2021-09-27]
@@ -682,7 +690,7 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
("chinese-ctlau" "刘粤"
"CTLau.html" cn-gb-2312 "CTLau.el"
- ctlau-gb-converter
+ tit--ctlau-gb-converter
"\
;; \"CTLau.html\" is available at:
;;
@@ -707,7 +715,7 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
("chinese-ctlaub" "劉粵"
"CTLau-b5.html" big5 "CTLau-b5.el"
- ctlau-b5-converter
+ tit--ctlau-b5-converter
"\
;; \"CTLau-b5.html\" is available at:
;;
@@ -740,7 +748,8 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
;; input method is for inputting Big5 characters. Otherwise the input
;; method is for inputting CNS characters.
-(defun tsang-quick-converter (dicbuf tsang-p big5-p)
+(define-obsolete-function-alias 'tsang-quick-converter
#'tit--tsang-quick-converter "30.1")
+(defun tit--tsang-quick-converter (dicbuf tsang-p big5-p)
(let ((fulltitle (if tsang-p "倉頡" "簡易"))
dic)
(goto-char (point-max))
@@ -822,23 +831,28 @@ To get complete usage, invoke \"emacs -batch -f
batch-titdic-convert -h\"."
(if big5-p (nth 1 elt) (nth 2 elt))))))
(insert ")\n")))
-(defun tsang-b5-converter (dicbuf)
- (tsang-quick-converter dicbuf t t))
+(define-obsolete-function-alias 'tsang-b5-converter #'tit--tsang-b5-converter
"30.1")
+(defun tit--tsang-b5-converter (dicbuf)
+ (tit--tsang-quick-converter dicbuf t t))
-(defun quick-b5-converter (dicbuf)
- (tsang-quick-converter dicbuf nil t))
+(define-obsolete-function-alias 'quick-b5-converter #'tit--quick-b5-converter
"30.1")
+(defun tit--quick-b5-converter (dicbuf)
+ (tit--tsang-quick-converter dicbuf nil t))
-(defun tsang-cns-converter (dicbuf)
- (tsang-quick-converter dicbuf t nil))
+(define-obsolete-function-alias 'tsang-cns-converter
#'tit--tsang-cns-converter "30.1")
+(defun tit--tsang-cns-converter (dicbuf)
+ (tit--tsang-quick-converter dicbuf t nil))
-(defun quick-cns-converter (dicbuf)
- (tsang-quick-converter dicbuf nil nil))
+(define-obsolete-function-alias 'quick-cns-converter
#'tit--quick-cns-converter "30.1")
+(defun tit--quick-cns-converter (dicbuf)
+ (tit--tsang-quick-converter dicbuf nil nil))
;; Generate a code of a Quail package in the current buffer from
;; Pinyin dictionary in the buffer DICBUF. The input method name of
;; the Quail package is NAME, and the title string is TITLE.
-(defun py-converter (dicbuf)
+(define-obsolete-function-alias 'py-converter #'tit--py-converter "30.1")
+(defun tit--py-converter (dicbuf)
(goto-char (point-max))
(insert (format "%S\n" "汉字输入∷拼音∷
@@ -913,7 +927,8 @@ method `chinese-tonepy' with which you must specify tones
by digits
;; Ziranma dictionary in the buffer DICBUF. The input method name of
;; the Quail package is NAME, and the title string is TITLE.
-(defun ziranma-converter (dicbuf)
+(define-obsolete-function-alias 'ziranma-converter #'tit--ziranma-converter
"30.1")
+(defun tit--ziranma-converter (dicbuf)
(let (dic)
(with-current-buffer dicbuf
(goto-char (point-min))
@@ -1022,7 +1037,8 @@ To input symbols and punctuation, type `/' followed by
one of `a' to
;; method name of the Quail package is NAME, and the title string is
;; TITLE. DESCRIPTION is the string shown by describe-input-method.
-(defun ctlau-converter (dicbuf description)
+(define-obsolete-function-alias 'ctlau-converter #'tit--ctlau-converter "30.1")
+(defun tit--ctlau-converter (dicbuf description)
(goto-char (point-max))
(insert (format "%S\n" description))
(insert " '((\"\C-?\" . quail-delete-last-char)
@@ -1071,8 +1087,9 @@ To input symbols and punctuation, type `/' followed by
one of `a' to
(forward-line 1)))
(insert ")\n"))
-(defun ctlau-gb-converter (dicbuf)
- (ctlau-converter dicbuf
+(define-obsolete-function-alias 'ctlau-gb-converter #'tit--ctlau-gb-converter
"30.1")
+(defun tit--ctlau-gb-converter (dicbuf)
+ (tit--ctlau-converter dicbuf
"汉字输入∷刘锡祥式粤音∷
刘锡祥式粤语注音方案
@@ -1085,8 +1102,9 @@ To input symbols and punctuation, type `/' followed by
one of `a' to
Some infrequent GB characters are accessed by typing \\, followed by
the Cantonese romanization of the respective radical (部首)."))
-(defun ctlau-b5-converter (dicbuf)
- (ctlau-converter dicbuf
+(define-obsolete-function-alias 'ctlau-b5-converter #'tit--ctlau-b5-converter
"30.1")
+(defun tit--ctlau-b5-converter (dicbuf)
+ (tit--ctlau-converter dicbuf
"漢字輸入：劉錫祥式粵音：
劉錫祥式粵語注音方案
@@ -1101,14 +1119,15 @@ To input symbols and punctuation, type `/' followed by
one of `a' to
(declare-function dos-8+3-filename "dos-fns.el" (filename))
-(defun miscdic-convert (filename &optional dirname)
+(define-obsolete-function-alias 'miscdic-convert #'tit-miscdic-convert "30.1")
+(defun tit-miscdic-convert (filename &optional dirname)
"Convert a dictionary file FILENAME into a Quail package.
Optional argument DIRNAME if specified is the directory name under which
the generated Quail package is saved."
(interactive "FInput method dictionary file: ")
(or (file-readable-p filename)
(error "%s does not exist" filename))
- (let ((tail quail-misc-package-ext-info)
+ (let ((tail tit-quail-misc-package-ext-info)
coding-system-for-write
slot
name title dicfile coding quailfile converter copyright)
@@ -1137,7 +1156,7 @@ the generated Quail package is saved."
;; Explicitly set eol format to `unix'.
(setq coding-system-for-write 'utf-8-unix)
(with-temp-file (expand-file-name quailfile dirname)
- (generate-lisp-file-heading quailfile 'miscdic-convert)
+ (generate-lisp-file-heading quailfile 'tit-miscdic-convert)
(insert (format-message ";; Quail package `%s'\n" name))
(insert ";; Source dictionary file: " dicfile "\n")
(insert ";; Copyright notice of the source file\n")
@@ -1164,15 +1183,17 @@ the generated Quail package is saved."
quailfile :inhibit-provide t :compile t :coding nil)))
(setq tail (cdr tail)))))
-(defun batch-miscdic-convert ()
- "Run `miscdic-convert' on the files remaining on the command line.
+;; Used in `Makefile.in'.
+(define-obsolete-function-alias 'batch-miscdic-convert
#'batch-tit-miscdic-convert "30.1")
+(defun batch-tit-miscdic-convert ()
+ "Run `tit-miscdic-convert' on the files remaining on the command line.
Use this from the command line, with `-batch';
it won't work in an interactive Emacs.
If there's an argument \"-dir\", the next argument specifies a directory
to store generated Quail packages."
(defvar command-line-args-left) ; Avoid compiler warning.
(if (not noninteractive)
- (error "`batch-miscdic-convert' should be used only with -batch"))
+ (error "`batch-tit-miscdic-convert' should be used only with -batch"))
(let ((dir default-directory)
filename)
(while command-line-args-left
@@ -1186,11 +1207,13 @@ to store generated Quail packages."
(if (file-directory-p filename)
(dolist (file (directory-files filename t nil t))
(or (file-directory-p file)
- (miscdic-convert file dir)))
- (miscdic-convert filename dir))))
+ (tit-miscdic-convert file dir)))
+ (tit-miscdic-convert filename dir))))
(kill-emacs 0))
-(defun pinyin-convert ()
+;; Used in `Makefile.in'.
+(define-obsolete-function-alias 'pinyin-convert #'tit-pinyin-convert "30.1")
+(defun tit-pinyin-convert ()
"Convert text file pinyin.map into an elisp library.
The library is named pinyin.el, and contains the constant
`pinyin-character-map'."
diff --git a/lisp/loadup.el b/lisp/loadup.el
index c498c0e53af..c6a8dcbb909 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -635,6 +635,8 @@ directory got moved. This is set to be a pair in the form
of:
(unwind-protect
(let ((tmp-dump-mode dump-mode)
(dump-mode nil)
+ ;; Set `lexical-binding' to nil by default
+ ;; in the dumped Emacs.
(lexical-binding nil))
(if (member tmp-dump-mode '("pdump" "pbootstrap"))
(dump-emacs-portable (expand-file-name output
invocation-directory))
diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el
index 668cae05521..cfdbc1b2509 100644
--- a/lisp/mail/mail-extr.el
+++ b/lisp/mail/mail-extr.el
@@ -1845,7 +1845,7 @@ place. It affects how `mail-extract-address-components'
works."
;; https://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
(defconst mail-extr-all-top-level-domains
- (let ((ob (make-vector 739 0)))
+ (let ((ob (obarray-make 739)))
(mapc
(lambda (x)
(put (intern (downcase (car x)) ob)
diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el
index 68d325ea261..c8006294a7d 100644
--- a/lisp/mail/mailabbrev.el
+++ b/lisp/mail/mailabbrev.el
@@ -171,7 +171,7 @@ no aliases, which is represented by this being a table with
no entries.)")
;;;###autoload
(defun mail-abbrevs-setup ()
"Initialize use of the `mailabbrev' package."
- (if (and (not (vectorp mail-abbrevs))
+ (if (and (not (obarrayp mail-abbrevs))
(file-exists-p mail-personal-alias-file))
(progn
(setq mail-abbrev-modtime
@@ -196,7 +196,7 @@ no aliases, which is represented by this being a table with
no entries.)")
"Read mail aliases from personal mail alias file and set `mail-abbrevs'.
By default this is the file specified by `mail-personal-alias-file'."
(setq file (expand-file-name (or file mail-personal-alias-file)))
- (if (vectorp mail-abbrevs)
+ (if (obarrayp mail-abbrevs)
nil
(setq mail-abbrevs nil)
(define-abbrev-table 'mail-abbrevs '()))
@@ -278,7 +278,7 @@ double-quotes."
;; true, and we do some evil space->comma hacking like /bin/mail does.
(interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
;; Read the defaults first, if we have not done so.
- (unless (vectorp mail-abbrevs) (build-mail-abbrevs))
+ (unless (obarrayp mail-abbrevs) (build-mail-abbrevs))
;; strip garbage from front and end
(if (string-match "\\`[ \t\n,]+" definition)
(setq definition (substring definition (match-end 0))))
@@ -355,7 +355,7 @@ double-quotes."
(if mail-abbrev-aliases-need-to-be-resolved
(progn
;; (message "Resolving mail aliases...")
- (if (vectorp mail-abbrevs)
+ (if (obarrayp mail-abbrevs)
(mapatoms (function mail-resolve-all-aliases-1) mail-abbrevs))
(setq mail-abbrev-aliases-need-to-be-resolved nil)
;; (message "Resolving mail aliases... done.")
@@ -555,9 +555,9 @@ of a mail alias. The value is set up, buffer-local, when
first needed.")
(defun mail-abbrev-insert-alias (&optional alias)
"Prompt for and insert a mail alias."
(interactive (progn
- (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup))
+ (if (not (obarrayp mail-abbrevs)) (mail-abbrevs-setup))
(list (completing-read "Expand alias: " mail-abbrevs nil t))))
- (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup))
+ (if (not (obarrayp mail-abbrevs)) (mail-abbrevs-setup))
(insert (or (and alias (symbol-value (intern-soft alias mail-abbrevs))) ""))
(mail-abbrev-expand-hook))
diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el
index 85eaec33660..d422383acdf 100644
--- a/lisp/mail/rmail.el
+++ b/lisp/mail/rmail.el
@@ -805,8 +805,8 @@ that knows the exact ordering of the \\( \\)
subexpressions.")
"\\(" cite-chars "[ \t]*\\)\\)+\\)"
"\\(.*\\)")
(beginning-of-line) (end-of-line)
- (1 font-lock-comment-delimiter-face nil t)
- (5 font-lock-comment-face nil t)))
+ (1 'font-lock-comment-delimiter-face nil t)
+ (5 'font-lock-comment-face nil t)))
'("^\\(X-[a-z0-9-]+\\|In-Reply-To\\|Date\\):.*\\(\n[ \t]+.*\\)*$"
. 'rmail-header-name))))
"Additional expressions to highlight in Rmail mode.")
@@ -815,7 +815,7 @@ that knows the exact ordering of the \\( \\)
subexpressions.")
(defun rmail-pop-to-buffer (&rest args)
"Like `pop-to-buffer', but with `split-width-threshold' set to nil."
(let (split-width-threshold)
- (apply 'pop-to-buffer args)))
+ (apply #'pop-to-buffer args)))
;; Perform BODY in the summary buffer
;; in such a way that its cursor is properly updated in its own window.
@@ -1008,66 +1008,66 @@ The buffer is expected to be narrowed to just the
header of the message."
(defvar rmail-mode-map
(let ((map (make-keymap)))
(suppress-keymap map)
- (define-key map "a" 'rmail-add-label)
- (define-key map "b" 'rmail-bury)
- (define-key map "c" 'rmail-continue)
- (define-key map "d" 'rmail-delete-forward)
- (define-key map "\C-d" 'rmail-delete-backward)
- (define-key map "e" 'rmail-edit-current-message)
+ (define-key map "a" #'rmail-add-label)
+ (define-key map "b" #'rmail-bury)
+ (define-key map "c" #'rmail-continue)
+ (define-key map "d" #'rmail-delete-forward)
+ (define-key map "\C-d" #'rmail-delete-backward)
+ (define-key map "e" #'rmail-edit-current-message)
;; If you change this, change the rmail-resend menu-item's :keys.
- (define-key map "f" 'rmail-forward)
- (define-key map "g" 'rmail-get-new-mail)
- (define-key map "h" 'rmail-summary)
- (define-key map "i" 'rmail-input)
- (define-key map "j" 'rmail-show-message)
- (define-key map "k" 'rmail-kill-label)
- (define-key map "l" 'rmail-summary-by-labels)
- (define-key map "\e\C-h" 'rmail-summary)
- (define-key map "\e\C-l" 'rmail-summary-by-labels)
- (define-key map "\e\C-r" 'rmail-summary-by-recipients)
- (define-key map "\e\C-s" 'rmail-summary-by-regexp)
- (define-key map "\e\C-f" 'rmail-summary-by-senders)
- (define-key map "\e\C-t" 'rmail-summary-by-topic)
- (define-key map "m" 'rmail-mail)
- (define-key map "\em" 'rmail-retry-failure)
- (define-key map "n" 'rmail-next-undeleted-message)
- (define-key map "\en" 'rmail-next-message)
- (define-key map "\e\C-n" 'rmail-next-labeled-message)
- (define-key map "o" 'rmail-output)
- (define-key map "\C-o" 'rmail-output-as-seen)
- (define-key map "p" 'rmail-previous-undeleted-message)
- (define-key map "\ep" 'rmail-previous-message)
- (define-key map "\e\C-p" 'rmail-previous-labeled-message)
- (define-key map "q" 'rmail-quit)
- (define-key map "r" 'rmail-reply)
+ (define-key map "f" #'rmail-forward)
+ (define-key map "g" #'rmail-get-new-mail)
+ (define-key map "h" #'rmail-summary)
+ (define-key map "i" #'rmail-input)
+ (define-key map "j" #'rmail-show-message)
+ (define-key map "k" #'rmail-kill-label)
+ (define-key map "l" #'rmail-summary-by-labels)
+ (define-key map "\e\C-h" #'rmail-summary)
+ (define-key map "\e\C-l" #'rmail-summary-by-labels)
+ (define-key map "\e\C-r" #'rmail-summary-by-recipients)
+ (define-key map "\e\C-s" #'rmail-summary-by-regexp)
+ (define-key map "\e\C-f" #'rmail-summary-by-senders)
+ (define-key map "\e\C-t" #'rmail-summary-by-topic)
+ (define-key map "m" #'rmail-mail)
+ (define-key map "\em" #'rmail-retry-failure)
+ (define-key map "n" #'rmail-next-undeleted-message)
+ (define-key map "\en" #'rmail-next-message)
+ (define-key map "\e\C-n" #'rmail-next-labeled-message)
+ (define-key map "o" #'rmail-output)
+ (define-key map "\C-o" #'rmail-output-as-seen)
+ (define-key map "p" #'rmail-previous-undeleted-message)
+ (define-key map "\ep" #'rmail-previous-message)
+ (define-key map "\e\C-p" #'rmail-previous-labeled-message)
+ (define-key map "q" #'rmail-quit)
+ (define-key map "r" #'rmail-reply)
;; I find I can't live without the default M-r command -- rms.
- ;; (define-key rmail-mode-map "\er" 'rmail-search-backwards)
- (define-key map "s" 'rmail-expunge-and-save)
- (define-key map "\es" 'rmail-search)
- (define-key map "t" 'rmail-toggle-header)
- (define-key map "u" 'rmail-undelete-previous-message)
- (define-key map "v" 'rmail-mime)
- (define-key map "w" 'rmail-output-body-to-file)
- (define-key map "\C-c\C-w" 'rmail-widen)
- (define-key map "x" 'rmail-expunge)
- (define-key map "." 'rmail-beginning-of-message)
- (define-key map "/" 'rmail-end-of-message)
- (define-key map "<" 'rmail-first-message)
- (define-key map ">" 'rmail-last-message)
- (define-key map " " 'scroll-up-command)
- (define-key map [?\S-\ ] 'scroll-down-command)
- (define-key map "\177" 'scroll-down-command)
- (define-key map "?" 'describe-mode)
- (define-key map "\C-c\C-d" 'rmail-epa-decrypt)
- (define-key map "\C-c\C-s\C-d" 'rmail-sort-by-date)
- (define-key map "\C-c\C-s\C-s" 'rmail-sort-by-subject)
- (define-key map "\C-c\C-s\C-a" 'rmail-sort-by-author)
- (define-key map "\C-c\C-s\C-r" 'rmail-sort-by-recipient)
- (define-key map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent)
- (define-key map "\C-c\C-s\C-l" 'rmail-sort-by-lines)
- (define-key map "\C-c\C-s\C-k" 'rmail-sort-by-labels)
- (define-key map "\C-c\C-n" 'rmail-next-same-subject)
- (define-key map "\C-c\C-p" 'rmail-previous-same-subject)
+ ;; (define-key rmail-mode-map "\er" #'rmail-search-backwards)
+ (define-key map "s" #'rmail-expunge-and-save)
+ (define-key map "\es" #'rmail-search)
+ (define-key map "t" #'rmail-toggle-header)
+ (define-key map "u" #'rmail-undelete-previous-message)
+ (define-key map "v" #'rmail-mime)
+ (define-key map "w" #'rmail-output-body-to-file)
+ (define-key map "\C-c\C-w" #'rmail-widen)
+ (define-key map "x" #'rmail-expunge)
+ (define-key map "." #'rmail-beginning-of-message)
+ (define-key map "/" #'rmail-end-of-message)
+ (define-key map "<" #'rmail-first-message)
+ (define-key map ">" #'rmail-last-message)
+ (define-key map " " #'scroll-up-command)
+ (define-key map [?\S-\ ] #'scroll-down-command)
+ (define-key map "\177" #'scroll-down-command)
+ (define-key map "?" #'describe-mode)
+ (define-key map "\C-c\C-d" #'rmail-epa-decrypt)
+ (define-key map "\C-c\C-s\C-d" #'rmail-sort-by-date)
+ (define-key map "\C-c\C-s\C-s" #'rmail-sort-by-subject)
+ (define-key map "\C-c\C-s\C-a" #'rmail-sort-by-author)
+ (define-key map "\C-c\C-s\C-r" #'rmail-sort-by-recipient)
+ (define-key map "\C-c\C-s\C-c" #'rmail-sort-by-correspondent)
+ (define-key map "\C-c\C-s\C-l" #'rmail-sort-by-lines)
+ (define-key map "\C-c\C-s\C-k" #'rmail-sort-by-labels)
+ (define-key map "\C-c\C-n" #'rmail-next-same-subject)
+ (define-key map "\C-c\C-p" #'rmail-previous-same-subject)
(define-key map [menu-bar] (make-sparse-keymap))
@@ -1344,9 +1344,9 @@ Instead, these commands are available:
(setq local-abbrev-table text-mode-abbrev-table)
;; Functions to support buffer swapping:
(add-hook 'write-region-annotate-functions
- 'rmail-write-region-annotate nil t)
- (add-hook 'kill-buffer-hook 'rmail-mode-kill-buffer-hook nil t)
- (add-hook 'change-major-mode-hook 'rmail-change-major-mode-hook nil t))
+ #'rmail-write-region-annotate nil t)
+ (add-hook 'kill-buffer-hook #'rmail-mode-kill-buffer-hook nil t)
+ (add-hook 'change-major-mode-hook #'rmail-change-major-mode-hook nil t))
(defun rmail-generate-viewer-buffer ()
"Return a reusable buffer suitable for viewing messages.
@@ -1363,7 +1363,7 @@ Create the buffer if necessary."
(file-name-nondirectory
(or buffer-file-name (buffer-name)))))))
(with-current-buffer newbuf
- (add-hook 'kill-buffer-hook 'rmail-view-buffer-kill-buffer-hook nil t))
+ (add-hook 'kill-buffer-hook #'rmail-view-buffer-kill-buffer-hook nil t))
newbuf)))
(defun rmail-swap-buffers ()
@@ -1479,7 +1479,7 @@ If so restore the actual mbox message collection."
;; Don't turn off auto-saving based on the size of the buffer
;; because that code does not understand buffer-swapping.
(setq-local auto-save-include-big-deletions t)
- (setq-local revert-buffer-function 'rmail-revert)
+ (setq-local revert-buffer-function #'rmail-revert)
(setq-local font-lock-defaults
'(rmail-font-lock-keywords
t t nil nil
@@ -1490,7 +1490,7 @@ If so restore the actual mbox message collection."
(setq-local file-precious-flag t)
(setq-local desktop-save-buffer t)
(setq-local save-buffer-coding-system 'no-conversion)
- (setq next-error-move-function 'rmail-next-error-move))
+ (setq next-error-move-function #'rmail-next-error-move))
;; Handle M-x revert-buffer done in an rmail-mode buffer.
(defun rmail-revert (arg noconfirm)
@@ -1606,7 +1606,7 @@ The duplicate copy goes into the Rmail file just after
the original."
(files (directory-files start t rmail-secondary-file-regexp)))
;; Sort here instead of in directory-files
;; because this list is usually much shorter.
- (sort files 'string<))))
+ (sort files #'string<))))
(defun rmail-list-to-menu (menu-name l action &optional full-name)
(let ((menu (make-sparse-keymap menu-name))
@@ -2026,7 +2026,7 @@ Value is the size of the newly read mail after
conversion."
rmail-movemail-flags)
(list file tofile)
(if password (list password) nil))))
- (apply 'call-process args))
+ (apply #'call-process args))
(if (not (buffer-modified-p errors))
;; No output => movemail won
nil
@@ -2518,7 +2518,7 @@ Output a helpful message unless NOMSG is non-nil."
;; which will never be used.
(push nil messages-head)
(push ?0 deleted-head)
- (setq rmail-message-vector (apply 'vector messages-head)
+ (setq rmail-message-vector (apply #'vector messages-head)
rmail-deleted-vector (concat deleted-head))
(setq rmail-summary-vector (make-vector rmail-total-messages nil)
@@ -3605,10 +3605,10 @@ If `rmail-confirm-expunge' is non-nil, ask user to
confirm."
(cons (aref messages number) nil)))
(setq rmail-current-message new-message-number
rmail-total-messages counter
- rmail-message-vector (apply 'vector messages-head)
+ rmail-message-vector (apply #'vector messages-head)
rmail-deleted-vector (make-string (1+ counter) ?\s)
rmail-summary-vector (vconcat (nreverse new-summary))
- rmail-msgref-vector (apply 'vector (nreverse new-msgref))
+ rmail-msgref-vector (apply #'vector (nreverse new-msgref))
win t)))
(message "Expunging deleted messages...done")
(if (not win)
@@ -3891,7 +3891,7 @@ use \\[mail-yank-original] to yank the original message
into it."
(if (or references message-id)
(list (cons "References" (if references
(concat
- (mapconcat 'identity references " ")
+ (mapconcat #'identity references " ")
" " message-id)
message-id)))))))
@@ -4089,26 +4089,24 @@ typically for purposes of moderating a list."
(insert "Resent-Bcc: " (user-login-name) "\n"))
(insert "Resent-To: " (if (stringp address)
address
- (mapconcat 'identity address ",\n\t"))
+ (mapconcat #'identity address ",\n\t"))
"\n")
;; Expand abbrevs in the recipients.
(save-excursion
(if (featurep 'mailabbrev)
(let ((end (point-marker))
- (local-abbrev-table mail-abbrevs)
- (old-syntax-table (syntax-table)))
- (if (and (not (vectorp mail-abbrevs))
+ (local-abbrev-table mail-abbrevs))
+ (if (and (not (obarrayp mail-abbrevs))
(file-exists-p mail-personal-alias-file))
(build-mail-abbrevs))
(unless mail-abbrev-syntax-table
(mail-abbrev-make-syntax-table))
- (set-syntax-table mail-abbrev-syntax-table)
- (goto-char before)
- (while (and (< (point) end)
- (progn (forward-word-strictly 1)
- (<= (point) end)))
- (expand-abbrev))
- (set-syntax-table old-syntax-table))
+ (with-syntax-table mail-abbrev-syntax-table
+ (goto-char before)
+ (while (and (< (point) end)
+ (progn (forward-word-strictly 1)
+ (<= (point) end)))
+ (expand-abbrev))))
(expand-mail-aliases before (point)))))
;;>> Set up comment, if any.
(if (and (sequencep comment) (not (zerop (length comment))))
@@ -4335,7 +4333,7 @@ This has an effect only if a summary buffer exists."
(defun rmail-fontify-buffer-function ()
;; This function's symbol is bound to font-lock-fontify-buffer-function.
- (add-hook 'rmail-show-message-hook 'rmail-fontify-message nil t)
+ (add-hook 'rmail-show-message-hook #'rmail-fontify-message nil t)
;; If we're already showing a message, fontify it now.
(if rmail-current-message (rmail-fontify-message))
;; Prevent Font Lock mode from kicking in.
@@ -4346,7 +4344,7 @@ This has an effect only if a summary buffer exists."
(with-silent-modifications
(save-restriction
(widen)
- (remove-hook 'rmail-show-message-hook 'rmail-fontify-message t)
+ (remove-hook 'rmail-show-message-hook #'rmail-fontify-message t)
(remove-text-properties (point-min) (point-max) '(rmail-fontified nil))
(font-lock-default-unfontify-buffer))))
@@ -4381,11 +4379,12 @@ browsing, and moving of messages."
"Install those variables used by speedbar to enhance rmail."
(unless rmail-speedbar-key-map
(setq rmail-speedbar-key-map (speedbar-make-specialized-keymap))
- (define-key rmail-speedbar-key-map "e" 'speedbar-edit-line)
- (define-key rmail-speedbar-key-map "r" 'speedbar-edit-line)
- (define-key rmail-speedbar-key-map "\C-m" 'speedbar-edit-line)
+ (declare-function speedbar-edit-line "speedbar")
+ (define-key rmail-speedbar-key-map "e" #'speedbar-edit-line)
+ (define-key rmail-speedbar-key-map "r" #'speedbar-edit-line)
+ (define-key rmail-speedbar-key-map "\C-m" #'speedbar-edit-line)
(define-key rmail-speedbar-key-map "M"
- 'rmail-speedbar-move-message-to-folder-on-line)))
+ #'rmail-speedbar-move-message-to-folder-on-line)))
;; Mouse-3.
(defvar rmail-speedbar-menu-items
@@ -4829,7 +4828,8 @@ Content-Transfer-Encoding: base64\n")
(with-current-buffer
(if (rmail-buffers-swapped-p) rmail-buffer rmail-view-buffer)
(setq buffer-file-coding-system rmail-message-encoding))))
-(add-hook 'after-save-hook 'rmail-after-save-hook)
+;; FIXME: Don't do it globally!!
+(add-hook 'after-save-hook #'rmail-after-save-hook)
;;; Mailing list support
diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el
index d9c4cb8cfee..a13c42edb5c 100644
--- a/lisp/mail/rmailkwd.el
+++ b/lisp/mail/rmailkwd.el
@@ -31,7 +31,7 @@
;; Global to all RMAIL buffers. It exists for the sake of completion.
;; It is better to use strings with the label functions and let them
;; worry about making the label.
-(defvar rmail-label-obarray (make-vector 47 0)
+(defvar rmail-label-obarray (obarray-make 47)
"Obarray of labels used by Rmail.
`rmail-read-label' uses this to offer completion.")
diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el
index 47c6a8f0613..5b290899ff5 100644
--- a/lisp/menu-bar.el
+++ b/lisp/menu-bar.el
@@ -1353,6 +1353,15 @@ mail status in mode line"))
(frame-visible-p
(symbol-value 'speedbar-frame))))))
+ (bindings--define-key menu [showhide-outline-minor-mode]
+ '(menu-item "Outlines" outline-minor-mode
+ :help "Turn outline-minor-mode on/off"
+ :visible (seq-some #'local-variable-p
+ '(outline-search-function
+ outline-regexp outline-level))
+ :button (:toggle . (and (boundp 'outline-minor-mode)
+ outline-minor-mode))))
+
(bindings--define-key menu [showhide-tab-line-mode]
'(menu-item "Window Tab Line" global-tab-line-mode
:help "Turn window-local tab-lines on/off"
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 642ffad171a..099fa1599d5 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -321,7 +321,7 @@ the form (concat S2 S)."
;; Predicates are called differently depending on the nature of
;; the completion table :-(
(cond
- ((vectorp table) ;Obarray.
+ ((obarrayp table)
(lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
((hash-table-p table)
(lambda (s _v) (funcall pred (concat prefix s))))
@@ -1970,10 +1970,13 @@ appear to be a match."
;; Allow user to specify null string
((= beg end) (funcall exit-function))
;; The CONFIRM argument is a predicate.
- ((and (functionp minibuffer-completion-confirm)
- (funcall minibuffer-completion-confirm
- (buffer-substring beg end)))
- (funcall exit-function))
+ ((functionp minibuffer-completion-confirm)
+ (if (funcall minibuffer-completion-confirm
+ (buffer-substring beg end))
+ (funcall exit-function)
+ (unless completion-fail-discreetly
+ (ding)
+ (completion--message "No match"))))
;; See if we have a completion from the table.
((test-completion (buffer-substring beg end)
minibuffer-completion-table
@@ -3482,9 +3485,10 @@ Fourth arg MUSTMATCH can take the following values:
input, but she needs to confirm her choice if she called
`minibuffer-complete' right before `minibuffer-complete-and-exit'
and the input is not an existing file.
-- a function, which will be called with the input as the
- argument. If the function returns a non-nil value, the
- minibuffer is exited with that argument as the value.
+- a function, which will be called with a single argument, the
+ input unquoted by `substitute-in-file-name', which see. If the
+ function returns a non-nil value, the minibuffer is exited with
+ that argument as the value.
- anything else behaves like t except that typing RET does not exit if it
does non-null completion.
@@ -3573,7 +3577,13 @@ See `read-file-name' for the meaning of the arguments."
(let ((ignore-case read-file-name-completion-ignore-case)
(minibuffer-completing-file-name t)
(pred (or predicate 'file-exists-p))
- (add-to-history nil))
+ (add-to-history nil)
+ (require-match (if (functionp mustmatch)
+ (lambda (input)
+ (funcall mustmatch
+ ;; User-supplied MUSTMATCH expects an
unquoted filename
+ (substitute-in-file-name input)))
+ mustmatch)))
(let* ((val
(if (or (not (next-read-file-uses-dialog-p))
@@ -3609,7 +3619,7 @@ See `read-file-name' for the meaning of the arguments."
(read-file-name--defaults dir initial))))
(set-syntax-table minibuffer-local-filename-syntax))
(completing-read prompt 'read-file-name-internal
- pred mustmatch insdef
+ pred require-match insdef
'file-name-history default-filename)))
;; If DEFAULT-FILENAME not supplied and DIR contains
;; a file name, split it.
diff --git a/lisp/mpc.el b/lisp/mpc.el
index 9577e0f2f42..768c70c2e3a 100644
--- a/lisp/mpc.el
+++ b/lisp/mpc.el
@@ -1867,11 +1867,14 @@ A value of t means the main playlist.")
(defvar mpc-volume nil) (put 'mpc-volume 'risky-local-variable t)
(defun mpc-volume-refresh ()
- ;; Maintain the volume.
- (setq mpc-volume
- (mpc-volume-widget
- (string-to-number (cdr (assq 'volume mpc-status)))))
- (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status)))
+ "Maintain the volume."
+ (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status))
+ (status-vol (cdr (assq 'volume mpc-status))))
+ ;; If MPD is paused or stopped the volume is nil.
+ (when status-vol
+ (setq mpc-volume
+ (mpc-volume-widget
+ (string-to-number status-vol))))
(when (buffer-live-p status-buf)
(with-current-buffer status-buf (force-mode-line-update)))))
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index 359453ca433..ddc57724343 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -688,8 +688,10 @@ websites are increasingly rare, but they do still exist."
(defun browse-url-url-at-point ()
(or (thing-at-point 'url t)
;; assume that the user is pointing at something like gnu.org/gnu
- (let ((f (thing-at-point 'filename t)))
- (and f (concat browse-url-default-scheme "://" f)))))
+ (when-let ((f (thing-at-point 'filename t)))
+ (if (string-match-p browse-url-button-regexp f)
+ f
+ (concat browse-url-default-scheme "://" f)))))
;; Having this as a separate function called by the browser-specific
;; functions allows them to be stand-alone commands, making it easier
@@ -1322,7 +1324,7 @@ and instant messengers instead of opening it in a web
browser."
:type 'boolean
:version "30.1")
-(declare-function android-browse-url "androidselect.c")
+(declare-function android-browse-url "../term/android-win")
;;;###autoload
(defun browse-url-default-android-browser (url &optional _new-window)
diff --git a/lisp/net/dns.el b/lisp/net/dns.el
index 23ea88ef4ad..54f4d227a49 100644
--- a/lisp/net/dns.el
+++ b/lisp/net/dns.el
@@ -359,7 +359,7 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
result))
;;; Interface functions.
-(defvar dns-cache (make-vector 4096 0))
+(defvar dns-cache (obarray-make 4096))
(defun dns-query-cached (name &optional type fullp reversep)
(let* ((key (format "%s:%s:%s:%s" name type fullp reversep))
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 6ae1e6d3d0a..5a25eef9e3c 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -340,7 +340,7 @@ parameter, and should return the (possibly) transformed
URL."
(defun eww-suggested-uris nil
"Return the list of URIs to suggest at the `eww' prompt.
This list can be customized via `eww-suggest-uris'."
- (let ((obseen (make-vector 42 0))
+ (let ((obseen (obarray-make 42))
(uris nil))
(dolist (fun eww-suggest-uris)
(let ((ret (funcall fun)))
diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index f10b5b8fc12..a06740528e9 100644
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -1057,7 +1057,7 @@ necessary. If nil, the buffer name is generated."
(setq imap-capability nil)
(setq streams nil))))))
(when (imap-opened buffer)
- (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
+ (setq imap-mailbox-data (obarray-make imap-mailbox-prime)))
;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state
imap-auth buffer)
(when imap-stream
buffer))))
@@ -1280,7 +1280,7 @@ If EXAMINE is non-nil, do a read-only select."
(concat (if examine "EXAMINE" "SELECT") " \""
mailbox "\"")))
(progn
- (setq imap-message-data (make-vector imap-message-prime 0)
+ (setq imap-message-data (obarray-make imap-message-prime)
imap-state (if examine 'examine 'selected))
imap-current-mailbox)
;; Failed SELECT/EXAMINE unselects current mailbox
@@ -1722,7 +1722,7 @@ See `imap-enable-exchange-bug-workaround'."
(string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
(let ((old-mailbox imap-current-mailbox)
(state imap-state)
- (imap-message-data (make-vector 2 0)))
+ (imap-message-data (obarray-make 2)))
(when (imap-mailbox-examine-1 mailbox)
(prog1
(and (imap-fetch-safe '("*" . "*:*") "UID")
@@ -1768,7 +1768,7 @@ first element. The rest of list contains the saved
articles' UIDs."
(imap-mailbox-get-1 'appenduid mailbox)
(let ((old-mailbox imap-current-mailbox)
(state imap-state)
- (imap-message-data (make-vector 2 0)))
+ (imap-message-data (obarray-make 2)))
(when (imap-mailbox-examine-1 mailbox)
(prog1
(and (imap-fetch-safe '("*" . "*:*") "UID")
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 17fdffd619d..e23fc6104d2 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -1437,13 +1437,85 @@ ones, in case fg and bg are nil."
(shr-dom-print elem)))))
(insert (format "</%s>" (dom-tag dom))))
+(defconst shr-correct-attribute-case
+ '((attributename . attributeName)
+ (attributetype . attributeType)
+ (basefrequency . baseFrequency)
+ (baseprofile . baseProfile)
+ (calcmode . calcMode)
+ (clippathunits . clipPathUnits)
+ (diffuseconstant . diffuseConstant)
+ (edgemode . edgeMode)
+ (filterunits . filterUnits)
+ (glyphref . glyphRef)
+ (gradienttransform . gradientTransform)
+ (gradientunits . gradientUnits)
+ (kernelmatrix . kernelMatrix)
+ (kernelunitlength . kernelUnitLength)
+ (keypoints . keyPoints)
+ (keysplines . keySplines)
+ (keytimes . keyTimes)
+ (lengthadjust . lengthAdjust)
+ (limitingconeangle . limitingConeAngle)
+ (markerheight . markerHeight)
+ (markerunits . markerUnits)
+ (markerwidth . markerWidth)
+ (maskcontentunits . maskContentUnits)
+ (maskunits . maskUnits)
+ (numoctaves . numOctaves)
+ (pathlength . pathLength)
+ (patterncontentunits . patternContentUnits)
+ (patterntransform . patternTransform)
+ (patternunits . patternUnits)
+ (pointsatx . pointsAtX)
+ (pointsaty . pointsAtY)
+ (pointsatz . pointsAtZ)
+ (preservealpha . preserveAlpha)
+ (preserveaspectratio . preserveAspectRatio)
+ (primitiveunits . primitiveUnits)
+ (refx . refX)
+ (refy . refY)
+ (repeatcount . repeatCount)
+ (repeatdur . repeatDur)
+ (requiredextensions . requiredExtensions)
+ (requiredfeatures . requiredFeatures)
+ (specularconstant . specularConstant)
+ (specularexponent . specularExponent)
+ (spreadmethod . spreadMethod)
+ (startoffset . startOffset)
+ (stddeviation . stdDeviation)
+ (stitchtiles . stitchTiles)
+ (surfacescale . surfaceScale)
+ (systemlanguage . systemLanguage)
+ (tablevalues . tableValues)
+ (targetx . targetX)
+ (targety . targetY)
+ (textlength . textLength)
+ (viewbox . viewBox)
+ (viewtarget . viewTarget)
+ (xchannelselector . xChannelSelector)
+ (ychannelselector . yChannelSelector)
+ (zoomandpan . zoomAndPan))
+ "Attributes for correcting the case in SVG and MathML.
+Based on
https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inforeign .")
+
+(defun shr-correct-dom-case (dom)
+ "Correct the case for SVG segments."
+ (dolist (attr (dom-attributes dom))
+ (when-let ((rep (assoc-default (car attr) shr-correct-attribute-case)))
+ (setcar attr rep)))
+ (dolist (child (dom-children dom))
+ (shr-correct-dom-case child))
+ dom)
+
(defun shr-tag-svg (dom)
(when (and (image-type-available-p 'svg)
(not shr-inhibit-images)
(dom-attr dom 'width)
(dom-attr dom 'height))
- (funcall shr-put-image-function (list (shr-dom-to-xml dom 'utf-8)
- 'image/svg+xml)
+ (funcall shr-put-image-function
+ (list (shr-dom-to-xml (shr-correct-dom-case dom) 'utf-8)
+ 'image/svg+xml)
"SVG Image")))
(defun shr-tag-sup (dom)
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index 2e4ad1cc412..8ad7c271b4f 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -263,9 +263,10 @@ arguments to pass to the OPERATION."
(tramp-convert-file-attributes v localname id-format
(and
(tramp-adb-send-command-and-check
- v (format "%s -d -l %s | cat"
+ v (format "(%s -d -l %s; echo tramp_exit_status $?) | cat"
(tramp-adb-get-ls-command v)
- (tramp-shell-quote-argument localname)))
+ (tramp-shell-quote-argument localname))
+ nil t)
(with-current-buffer (tramp-get-buffer v)
(tramp-adb-sh-fix-ls-output)
(cdar (tramp-do-parse-file-attributes-with-ls v)))))))
@@ -316,9 +317,10 @@ arguments to pass to the OPERATION."
directory full match nosort id-format count
(with-current-buffer (tramp-get-buffer v)
(when (tramp-adb-send-command-and-check
- v (format "%s -a -l %s | cat"
+ v (format "(%s -a -l %s; echo tramp_exit_status $?) | cat"
(tramp-adb-get-ls-command v)
- (tramp-shell-quote-argument localname)))
+ (tramp-shell-quote-argument localname))
+ nil t)
;; We insert also filename/. and filename/.., because "ls"
;; doesn't on some file systems, like "sdcard".
(unless (search-backward-regexp (rx "." eol) nil t)
@@ -440,10 +442,12 @@ Emacs dired can't find files."
filename
(with-parsed-tramp-file-name (expand-file-name directory) nil
(with-tramp-file-property v localname "file-name-all-completions"
- (tramp-adb-send-command
- v (format "%s -a %s | cat"
- (tramp-adb-get-ls-command v)
- (tramp-shell-quote-argument localname)))
+ (unless (tramp-adb-send-command-and-check
+ v (format "(%s -a %s; echo tramp_exit_status $?) | cat"
+ (tramp-adb-get-ls-command v)
+ (tramp-shell-quote-argument localname))
+ nil t)
+ (erase-buffer))
(mapcar
(lambda (f)
(if (file-directory-p (expand-file-name f directory))
@@ -1142,17 +1146,23 @@ error and non-nil on success."
(while (search-forward-regexp (rx (+ "\r") eol) nil t)
(replace-match "" nil nil)))))))
-(defun tramp-adb-send-command-and-check (vec command &optional exit-status)
+(defun tramp-adb-send-command-and-check
+ (vec command &optional exit-status command-augmented-p)
"Run COMMAND and check its exit status.
Sends `echo $?' along with the COMMAND for checking the exit
status. If COMMAND is nil, just sends `echo $?'. Returns nil if
the exit status is not equal 0, and t otherwise.
+If COMMAND-AUGMENTED-P, COMMAND is already configured to print exit
+status upon completion and need not be modified.
+
Optional argument EXIT-STATUS, if non-nil, triggers the return of
the exit status."
(tramp-adb-send-command
vec (if command
- (format "%s; echo tramp_exit_status $?" command)
+ (if command-augmented-p
+ command
+ (format "%s; echo tramp_exit_status $?" command))
"echo tramp_exit_status $?"))
(with-current-buffer (tramp-get-connection-buffer vec)
(unless (tramp-search-regexp (rx "tramp_exit_status " (+ digit)))
@@ -1230,7 +1240,7 @@ connection if a previous connection has died for some
reason."
(let* ((coding-system-for-read 'utf-8-dos) ; Is this correct?
(process-connection-type tramp-process-connection-type)
(args (tramp-expand-args
- vec 'tramp-login-args ?d (or device "")))
+ vec 'tramp-login-args nil ?d (or device "")))
(p (let ((default-directory
tramp-compat-temporary-file-directory))
(apply
diff --git a/lisp/net/tramp-androidsu.el b/lisp/net/tramp-androidsu.el
new file mode 100644
index 00000000000..fd9edb6a92e
--- /dev/null
+++ b/lisp/net/tramp-androidsu.el
@@ -0,0 +1,577 @@
+;;; tramp-androidsu.el --- TRAMP method for Android superuser shells -*-
lexical-binding:t -*-
+
+;; Copyright (C) 2024 Free Software Foundation, Inc.
+
+;; Keywords: comm, processes
+;; Package: tramp
+
+;; 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:
+
+;; The `su' method struggles (as do other shell-based methods) with the
+;; crippled versions of many Unix utilities installed on Android,
+;; workarounds for which are implemented in the `adb' method. This
+;; method defines a shell-based method that is identical in function to
+;; `su', but reuses such code from the `adb' method where applicable and
+;; also provides for certain mannerisms of popular Android `su'
+;; implementations.
+
+;;; Code:
+
+(require 'tramp)
+(require 'tramp-adb)
+(require 'tramp-sh)
+
+;;;###tramp-autoload
+(defconst tramp-androidsu-method "androidsu"
+ "When this method name is used, forward all calls to su.")
+
+;;;###tramp-autoload
+(defcustom tramp-androidsu-mount-global-namespace t
+ "When non-nil, browse files from within the global mount namespace.
+On systems that assign each application a unique view of the filesystem
+by executing them within individual mount namespaces and thus conceal
+each application's data directories from others, invoke `su' with the
+option `-mm' in order for the shell launched to run within the global
+mount namespace, so that TRAMP may edit files belonging to any and all
+applications."
+ :group 'tramp
+ :version "30.1"
+ :type 'boolean)
+
+(defvar tramp-androidsu-su-mm-supported 'unknown
+ "Whether `su -mm' is supported on this system.")
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (add-to-list 'tramp-methods
+ `(,tramp-androidsu-method
+ (tramp-login-program "su")
+ (tramp-login-args (("-") ("%u")))
+ (tramp-remote-shell "/system/bin/sh")
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-c"))
+ (tramp-tmpdir "/data/local/tmp")
+ (tramp-connection-timeout 10)))
+
+ (add-to-list 'tramp-default-host-alist
+ `(,tramp-androidsu-method nil "localhost")))
+
+(defvar android-use-exec-loader) ; androidfns.c.
+
+(defun tramp-androidsu-maybe-open-connection (vec)
+ "Open a connection VEC if not already open.
+Mostly identical to `tramp-adb-maybe-open-connection', but also disables
+multibyte mode and waits for the shell prompt to appear."
+ ;; During completion, don't reopen a new connection.
+ (unless (tramp-connectable-p vec)
+ (throw 'non-essential 'non-essential))
+
+ (with-tramp-debug-message vec "Opening connection"
+ (let ((p (tramp-get-connection-process vec))
+ (process-name (tramp-get-connection-property vec "process-name"))
+ (process-environment (copy-sequence process-environment)))
+ ;; Open a new connection.
+ (condition-case err
+ (unless (process-live-p p)
+ (with-tramp-progress-reporter
+ vec 3
+ (if (tramp-string-empty-or-nil-p (tramp-file-name-user vec))
+ (format "Opening connection %s for %s using %s"
+ process-name
+ (tramp-file-name-host vec)
+ (tramp-file-name-method vec))
+ (format "Opening connection %s for %s@%s using %s"
+ process-name
+ (tramp-file-name-user vec)
+ (tramp-file-name-host vec)
+ (tramp-file-name-method vec)))
+ (let* ((coding-system-for-read 'utf-8-unix)
+ (process-connection-type tramp-process-connection-type)
+ ;; The executable loader cannot execute setuid
+ ;; binaries, such as su.
+ (android-use-exec-loader nil)
+ (p (start-process (tramp-get-connection-name vec)
+ (tramp-get-connection-buffer vec)
+ ;; Disregard
+ ;; tramp-encoding-shell, as
+ ;; there's no guarantee that it's
+ ;; possible to execute it with
+ ;; `android-use-exec-loader' off.
+ "/system/bin/sh" "-i"))
+ (user (tramp-file-name-user vec))
+ command)
+ ;; Set sentinel. Initialize variables.
+ (set-process-sentinel p #'tramp-process-sentinel)
+ (tramp-post-process-creation p vec)
+
+ ;; Replace `login-args' place holders.
+ (setq command (format "exec su - %s || exit"
+ (or user "root")))
+
+ ;; Attempt to execute the shell inside the global mount
+ ;; namespace if requested.
+ (when tramp-androidsu-mount-global-namespace
+ (progn
+ (when (eq tramp-androidsu-su-mm-supported 'unknown)
+ ;; Change the prompt in advance so that
+ ;; tramp-adb-send-command-and-check can call
+ ;; tramp-search-regexp.
+ (tramp-adb-send-command
+ vec (format "PS1=%s"
+ (tramp-shell-quote-argument
+ tramp-end-of-output)))
+ (setq tramp-androidsu-su-mm-supported
+ ;; Detect support for `su -mm'.
+ (tramp-adb-send-command-and-check
+ vec "su -mm -c 'exit 24'" 24)))
+ (when tramp-androidsu-su-mm-supported
+ (setq command (format "exec su -mm - %s || exit"
+ (or user "root"))))))
+ ;; Send the command.
+ (tramp-message vec 3 "Sending command `%s'" command)
+ (tramp-adb-send-command vec command t t)
+ ;; Android su binaries contact a background service to
+ ;; obtain authentication; during this process, input
+ ;; received is discarded, so input cannot be
+ ;; guaranteed to reach the root shell until its prompt
+ ;; is displayed.
+ (with-current-buffer (process-buffer p)
+ (tramp-wait-for-regexp p tramp-connection-timeout
+ "#[[:space:]]*$"))
+
+ ;; Set connection-local variables.
+ (tramp-set-connection-local-variables vec)
+
+ ;; Change prompt.
+ (tramp-adb-send-command
+ vec (format "PS1=%s"
+ (tramp-shell-quote-argument tramp-end-of-output)))
+
+ ;; Disable line editing.
+ (tramp-adb-send-command
+ vec "set +o vi +o vi-esccomplete +o vi-tabcomplete +o emacs")
+
+ ;; Dump option settings in the traces.
+ (when (>= tramp-verbose 9)
+ (tramp-adb-send-command vec "set -o"))
+
+ ;; Disable Unicode.
+ (tramp-adb-send-command vec "set +U")
+
+ ;; Disable echo expansion.
+ (tramp-adb-send-command
+ vec "stty -inlcr -onlcr -echo kill '^U' erase '^H'" t)
+
+ ;; Check whether the echo has really been disabled.
+ ;; Some implementations, like busybox, don't support
+ ;; disabling.
+ (tramp-adb-send-command vec "echo foo" t)
+ (with-current-buffer (process-buffer p)
+ (goto-char (point-min))
+ (when (looking-at-p "echo foo")
+ (tramp-set-connection-property p "remote-echo" t)
+ (tramp-message vec 5 "Remote echo still on. Ok.")
+ ;; Make sure backspaces and their echo are enabled
+ ;; and no line width magic interferes with them.
+ (tramp-adb-send-command vec
+ "stty icanon erase ^H cols 32767"
+ t)))
+
+ ;; Set the remote PATH to a suitable value.
+ (tramp-set-connection-property vec "remote-path"
+ "/system/bin:/system/xbin")
+
+ ;; Mark it as connected.
+ (tramp-set-connection-property p "connected" t))))
+
+ ;; Cleanup, and propagate the signal.
+ ((error quit)
+ (tramp-cleanup-connection vec t)
+ (signal (car err) (cdr err)))))))
+
+(defun tramp-androidsu-generate-wrapper (function)
+ "Return connection wrapper function for FUNCTION.
+Return a function which temporarily substitutes local replacements for
+the `adb' method's connection management functions around a call to
+FUNCTION."
+ (lambda (&rest args)
+ (let ((tramp-adb-wait-for-output
+ (symbol-function #'tramp-adb-wait-for-output))
+ (tramp-adb-maybe-open-connection
+ (symbol-function #'tramp-adb-maybe-open-connection)))
+ (unwind-protect
+ (progn
+ ;; tramp-adb-wait-for-output addresses problems introduced
+ ;; by the adb utility itself, not Android utilities, so
+ ;; replace it with the regular TRAMP function.
+ (fset 'tramp-adb-wait-for-output #'tramp-wait-for-output)
+ ;; Likewise, except some special treatment is necessary on
+ ;; account of flaws in Android's su implementation.
+ (fset 'tramp-adb-maybe-open-connection
+ #'tramp-androidsu-maybe-open-connection)
+ (apply function args))
+ ;; Restore the original definitions of the functions overridden
+ ;; above.
+ (fset 'tramp-adb-wait-for-output tramp-adb-wait-for-output)
+ (fset 'tramp-adb-maybe-open-connection
tramp-adb-maybe-open-connection)))))
+
+(defalias 'tramp-androidsu-handle-access-file
+ (tramp-androidsu-generate-wrapper #'tramp-handle-access-file))
+
+(defalias 'tramp-androidsu-handle-add-name-to-file
+ (tramp-androidsu-generate-wrapper #'tramp-handle-add-name-to-file))
+
+(defalias 'tramp-androidsu-handle-copy-directory
+ (tramp-androidsu-generate-wrapper #'tramp-handle-copy-directory))
+
+(defalias 'tramp-androidsu-sh-handle-copy-file
+ (tramp-androidsu-generate-wrapper #'tramp-sh-handle-copy-file))
+
+(defalias 'tramp-androidsu-adb-handle-delete-directory
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-delete-directory))
+
+(defalias 'tramp-androidsu-adb-handle-delete-file
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-delete-file))
+
+(defalias 'tramp-androidsu-handle-directory-file-name
+ (tramp-androidsu-generate-wrapper #'tramp-handle-directory-file-name))
+
+(defalias 'tramp-androidsu-handle-directory-files
+ (tramp-androidsu-generate-wrapper #'tramp-handle-directory-files))
+
+(defalias 'tramp-androidsu-adb-handle-directory-files-and-attributes
+ (tramp-androidsu-generate-wrapper
#'tramp-adb-handle-directory-files-and-attributes))
+
+(defalias 'tramp-androidsu-handle-dired-uncache
+ (tramp-androidsu-generate-wrapper #'tramp-handle-dired-uncache))
+
+(defalias 'tramp-androidsu-adb-handle-exec-path
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-exec-path))
+
+(defalias 'tramp-androidsu-handle-expand-file-name
+ (tramp-androidsu-generate-wrapper #'tramp-handle-expand-file-name))
+
+(defalias 'tramp-androidsu-handle-file-accessible-directory-p
+ (tramp-androidsu-generate-wrapper
#'tramp-handle-file-accessible-directory-p))
+
+(defalias 'tramp-androidsu-adb-handle-file-attributes
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-attributes))
+
+(defalias 'tramp-androidsu-handle-file-directory-p
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-directory-p))
+
+(defalias 'tramp-androidsu-handle-file-equal-p
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-equal-p))
+
+(defalias 'tramp-androidsu-adb-handle-file-executable-p
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-executable-p))
+
+(defalias 'tramp-androidsu-adb-handle-file-exists-p
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-exists-p))
+
+(defalias 'tramp-androidsu-handle-file-group-gid
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-group-gid))
+
+(defalias 'tramp-androidsu-handle-file-in-directory-p
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-in-directory-p))
+
+(defalias 'tramp-androidsu-sh-handle-file-local-copy
+ (tramp-androidsu-generate-wrapper #'tramp-sh-handle-file-local-copy))
+
+(defalias 'tramp-androidsu-handle-file-locked-p
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-locked-p))
+
+(defalias 'tramp-androidsu-handle-file-modes
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-modes))
+
+(defalias 'tramp-androidsu-adb-handle-file-name-all-completions
+ (tramp-androidsu-generate-wrapper
#'tramp-adb-handle-file-name-all-completions))
+
+(defalias 'tramp-androidsu-handle-file-name-as-directory
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-name-as-directory))
+
+(defalias 'tramp-androidsu-handle-file-name-case-insensitive-p
+ (tramp-androidsu-generate-wrapper
#'tramp-handle-file-name-case-insensitive-p))
+
+(defalias 'tramp-androidsu-handle-file-name-completion
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-name-completion))
+
+(defalias 'tramp-androidsu-handle-file-name-directory
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-name-directory))
+
+(defalias 'tramp-androidsu-handle-file-name-nondirectory
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-name-nondirectory))
+
+(defalias 'tramp-androidsu-handle-file-newer-than-file-p
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-newer-than-file-p))
+
+(defalias 'tramp-androidsu-handle-file-notify-add-watch
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-notify-add-watch))
+
+(defalias 'tramp-androidsu-handle-file-notify-rm-watch
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-notify-rm-watch))
+
+(defalias 'tramp-androidsu-handle-file-notify-valid-p
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-notify-valid-p))
+
+(defalias 'tramp-androidsu-adb-handle-file-readable-p
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-readable-p))
+
+(defalias 'tramp-androidsu-handle-file-regular-p
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-regular-p))
+
+(defalias 'tramp-androidsu-handle-file-remote-p
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-remote-p))
+
+(defalias 'tramp-androidsu-handle-file-selinux-context
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-selinux-context))
+
+(defalias 'tramp-androidsu-handle-file-symlink-p
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-symlink-p))
+
+(defalias 'tramp-androidsu-adb-handle-file-system-info
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-system-info))
+
+(defalias 'tramp-androidsu-handle-file-truename
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-truename))
+
+(defalias 'tramp-androidsu-handle-file-user-uid
+ (tramp-androidsu-generate-wrapper #'tramp-handle-file-user-uid))
+
+(defalias 'tramp-androidsu-adb-handle-file-writable-p
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-file-writable-p))
+
+(defalias 'tramp-androidsu-handle-find-backup-file-name
+ (tramp-androidsu-generate-wrapper #'tramp-handle-find-backup-file-name))
+
+(defalias 'tramp-androidsu-handle-insert-directory
+ (tramp-androidsu-generate-wrapper #'tramp-handle-insert-directory))
+
+(defalias 'tramp-androidsu-handle-insert-file-contents
+ (tramp-androidsu-generate-wrapper #'tramp-handle-insert-file-contents))
+
+(defalias 'tramp-androidsu-handle-list-system-processes
+ (tramp-androidsu-generate-wrapper #'tramp-handle-list-system-processes))
+
+(defalias 'tramp-androidsu-handle-load
+ (tramp-androidsu-generate-wrapper #'tramp-handle-load))
+
+(defalias 'tramp-androidsu-handle-lock-file
+ (tramp-androidsu-generate-wrapper #'tramp-handle-lock-file))
+
+(defalias 'tramp-androidsu-handle-make-auto-save-file-name
+ (tramp-androidsu-generate-wrapper #'tramp-handle-make-auto-save-file-name))
+
+(defalias 'tramp-androidsu-adb-handle-make-directory
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-make-directory))
+
+(defalias 'tramp-androidsu-handle-make-lock-file-name
+ (tramp-androidsu-generate-wrapper #'tramp-handle-make-lock-file-name))
+
+(defalias 'tramp-androidsu-handle-make-nearby-temp-file
+ (tramp-androidsu-generate-wrapper #'tramp-handle-make-nearby-temp-file))
+
+(defalias 'tramp-androidsu-adb-handle-make-process
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-make-process))
+
+(defalias 'tramp-androidsu-sh-handle-make-symbolic-link
+ (tramp-androidsu-generate-wrapper
+ #'tramp-sh-handle-make-symbolic-link))
+
+(defalias 'tramp-androidsu-handle-memory-info
+ (tramp-androidsu-generate-wrapper #'tramp-handle-memory-info))
+
+(defalias 'tramp-androidsu-handle-process-attributes
+ (tramp-androidsu-generate-wrapper #'tramp-handle-process-attributes))
+
+(defalias 'tramp-androidsu-adb-handle-process-file
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-process-file))
+
+(defalias 'tramp-androidsu-sh-handle-rename-file
+ (tramp-androidsu-generate-wrapper #'tramp-sh-handle-rename-file))
+
+(defalias 'tramp-androidsu-adb-handle-set-file-modes
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-set-file-modes))
+
+(defalias 'tramp-androidsu-adb-handle-set-file-times
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-set-file-times))
+
+(defalias 'tramp-androidsu-handle-set-visited-file-modtime
+ (tramp-androidsu-generate-wrapper #'tramp-handle-set-visited-file-modtime))
+
+(defalias 'tramp-androidsu-handle-shell-command
+ (tramp-androidsu-generate-wrapper #'tramp-handle-shell-command))
+
+(defalias 'tramp-androidsu-handle-start-file-process
+ (tramp-androidsu-generate-wrapper #'tramp-handle-start-file-process))
+
+(defalias 'tramp-androidsu-handle-substitute-in-file-name
+ (tramp-androidsu-generate-wrapper #'tramp-handle-substitute-in-file-name))
+
+(defalias 'tramp-androidsu-handle-temporary-file-directory
+ (tramp-androidsu-generate-wrapper #'tramp-handle-temporary-file-directory))
+
+(defalias 'tramp-androidsu-adb-handle-get-remote-gid
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-gid))
+
+(defalias 'tramp-androidsu-adb-handle-get-remote-groups
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-groups))
+
+(defalias 'tramp-androidsu-adb-handle-get-remote-uid
+ (tramp-androidsu-generate-wrapper #'tramp-adb-handle-get-remote-uid))
+
+(defalias 'tramp-androidsu-handle-unlock-file
+ (tramp-androidsu-generate-wrapper #'tramp-handle-unlock-file))
+
+(defalias 'tramp-androidsu-handle-verify-visited-file-modtime
+ (tramp-androidsu-generate-wrapper
#'tramp-handle-verify-visited-file-modtime))
+
+(defalias 'tramp-androidsu-sh-handle-write-region
+ (tramp-androidsu-generate-wrapper #'tramp-sh-handle-write-region))
+
+;;;###tramp-autoload
+(defconst tramp-androidsu-file-name-handler-alist
+ '(;; `abbreviate-file-name' performed by default handler.
+ (access-file . tramp-androidsu-handle-access-file)
+ (add-name-to-file . tramp-androidsu-handle-add-name-to-file)
+ ;; `byte-compiler-base-file-name' performed by default handler.
+ (copy-directory . tramp-androidsu-handle-copy-directory)
+ (copy-file . tramp-androidsu-sh-handle-copy-file)
+ (delete-directory . tramp-androidsu-adb-handle-delete-directory)
+ (delete-file . tramp-androidsu-adb-handle-delete-file)
+ ;; `diff-latest-backup-file' performed by default handler.
+ (directory-file-name . tramp-androidsu-handle-directory-file-name)
+ (directory-files . tramp-androidsu-handle-directory-files)
+ (directory-files-and-attributes
+ . tramp-androidsu-adb-handle-directory-files-and-attributes)
+ (dired-compress-file . ignore)
+ (dired-uncache . tramp-androidsu-handle-dired-uncache)
+ (exec-path . tramp-androidsu-adb-handle-exec-path)
+ (expand-file-name . tramp-androidsu-handle-expand-file-name)
+ (file-accessible-directory-p .
tramp-androidsu-handle-file-accessible-directory-p)
+ (file-acl . ignore)
+ (file-attributes . tramp-androidsu-adb-handle-file-attributes)
+ (file-directory-p . tramp-androidsu-handle-file-directory-p)
+ (file-equal-p . tramp-androidsu-handle-file-equal-p)
+ (file-executable-p . tramp-androidsu-adb-handle-file-executable-p)
+ (file-exists-p . tramp-androidsu-adb-handle-file-exists-p)
+ (file-group-gid . tramp-androidsu-handle-file-group-gid)
+ (file-in-directory-p . tramp-androidsu-handle-file-in-directory-p)
+ (file-local-copy . tramp-androidsu-sh-handle-file-local-copy)
+ (file-locked-p . tramp-androidsu-handle-file-locked-p)
+ (file-modes . tramp-androidsu-handle-file-modes)
+ (file-name-all-completions .
tramp-androidsu-adb-handle-file-name-all-completions)
+ (file-name-as-directory . tramp-androidsu-handle-file-name-as-directory)
+ (file-name-case-insensitive-p .
tramp-androidsu-handle-file-name-case-insensitive-p)
+ (file-name-completion . tramp-androidsu-handle-file-name-completion)
+ (file-name-directory . tramp-androidsu-handle-file-name-directory)
+ (file-name-nondirectory . tramp-androidsu-handle-file-name-nondirectory)
+ ;; `file-name-sans-versions' performed by default handler.
+ (file-newer-than-file-p . tramp-androidsu-handle-file-newer-than-file-p)
+ (file-notify-add-watch . tramp-androidsu-handle-file-notify-add-watch)
+ (file-notify-rm-watch . tramp-androidsu-handle-file-notify-rm-watch)
+ (file-notify-valid-p . tramp-androidsu-handle-file-notify-valid-p)
+ (file-ownership-preserved-p . ignore)
+ (file-readable-p . tramp-androidsu-adb-handle-file-readable-p)
+ (file-regular-p . tramp-androidsu-handle-file-regular-p)
+ (file-remote-p . tramp-androidsu-handle-file-remote-p)
+ (file-selinux-context . tramp-androidsu-handle-file-selinux-context)
+ (file-symlink-p . tramp-androidsu-handle-file-symlink-p)
+ (file-system-info . tramp-androidsu-adb-handle-file-system-info)
+ (file-truename . tramp-androidsu-handle-file-truename)
+ (file-user-uid . tramp-androidsu-handle-file-user-uid)
+ (file-writable-p . tramp-androidsu-adb-handle-file-writable-p)
+ (find-backup-file-name . tramp-androidsu-handle-find-backup-file-name)
+ ;; `get-file-buffer' performed by default handler.
+ (insert-directory . tramp-androidsu-handle-insert-directory)
+ (insert-file-contents . tramp-androidsu-handle-insert-file-contents)
+ (list-system-processes . tramp-androidsu-handle-list-system-processes)
+ (load . tramp-androidsu-handle-load)
+ (lock-file . tramp-androidsu-handle-lock-file)
+ (make-auto-save-file-name .
tramp-androidsu-handle-make-auto-save-file-name)
+ (make-directory . tramp-androidsu-adb-handle-make-directory)
+ (make-directory-internal . ignore)
+ (make-lock-file-name . tramp-androidsu-handle-make-lock-file-name)
+ (make-nearby-temp-file . tramp-androidsu-handle-make-nearby-temp-file)
+ (make-process . tramp-androidsu-adb-handle-make-process)
+ (make-symbolic-link . tramp-androidsu-sh-handle-make-symbolic-link)
+ (memory-info . tramp-androidsu-handle-memory-info)
+ (process-attributes . tramp-androidsu-handle-process-attributes)
+ (process-file . tramp-androidsu-adb-handle-process-file)
+ (rename-file . tramp-androidsu-sh-handle-rename-file)
+ (set-file-acl . ignore)
+ (set-file-modes . tramp-androidsu-adb-handle-set-file-modes)
+ (set-file-selinux-context . ignore)
+ (set-file-times . tramp-androidsu-adb-handle-set-file-times)
+ (set-visited-file-modtime .
tramp-androidsu-handle-set-visited-file-modtime)
+ (shell-command . tramp-androidsu-handle-shell-command)
+ (start-file-process . tramp-androidsu-handle-start-file-process)
+ (substitute-in-file-name . tramp-androidsu-handle-substitute-in-file-name)
+ (temporary-file-directory .
tramp-androidsu-handle-temporary-file-directory)
+ (tramp-get-home-directory . ignore)
+ (tramp-get-remote-gid . tramp-androidsu-adb-handle-get-remote-gid)
+ (tramp-get-remote-groups . tramp-androidsu-adb-handle-get-remote-groups)
+ (tramp-get-remote-uid . tramp-androidsu-adb-handle-get-remote-uid)
+ (tramp-set-file-uid-gid . ignore)
+ (unhandled-file-name-directory . ignore)
+ (unlock-file . tramp-androidsu-handle-unlock-file)
+ (vc-registered . ignore)
+ (verify-visited-file-modtime .
tramp-androidsu-handle-verify-visited-file-modtime)
+ (write-region . tramp-androidsu-sh-handle-write-region))
+ "Alist of TRAMP handler functions for superuser sessions on Android.")
+
+;; It must be a `defsubst' in order to push the whole code into
+;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading.
+;;;###tramp-autoload
+(defsubst tramp-androidsu-file-name-p (vec-or-filename)
+ "Check whether VEC-OR-FILENAME is for the `androidsu' method."
+ (when-let* ((vec (tramp-ensure-dissected-file-name vec-or-filename)))
+ (equal (tramp-file-name-method vec) tramp-androidsu-method)))
+
+;;;###tramp-autoload
+(defun tramp-androidsu-file-name-handler (operation &rest args)
+ "Invoke the `androidsu' handler for OPERATION.
+First arg specifies the OPERATION, second arg is a list of
+arguments to pass to the OPERATION."
+ (if-let ((fn (assoc operation tramp-androidsu-file-name-handler-alist)))
+ (prog1 (save-match-data (apply (cdr fn) args))
+ (setq tramp-debug-message-fnh-function (cdr fn)))
+ (prog1 (tramp-run-real-handler operation args)
+ (setq tramp-debug-message-fnh-function operation))))
+
+;;;###tramp-autoload
+(tramp--with-startup
+ (tramp-register-foreign-file-name-handler
+ #'tramp-androidsu-file-name-p #'tramp-androidsu-file-name-handler))
+
+(connection-local-set-profile-variables
+ 'tramp-adb-connection-local-default-ps-profile
+ tramp-adb-connection-local-default-ps-variables)
+
+(with-eval-after-load 'shell
+ (connection-local-set-profiles
+ `(:application tramp :protocol ,tramp-adb-method)
+ 'tramp-adb-connection-local-default-shell-profile
+ 'tramp-adb-connection-local-default-ps-profile))
+
+(add-hook 'tramp-unload-hook
+ (lambda ()
+ (unload-feature 'tramp-androidsu 'force)))
+
+(provide 'tramp-androidsu)
+;;; tramp-androidsu.el ends here
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 298cacdb0e0..59c4223794c 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -387,6 +387,8 @@ arguments to pass to the OPERATION."
;;;###autoload
(progn (defun tramp-register-archive-autoload-file-name-handler ()
"Add archive file name handler to `file-name-handler-alist'."
+ ;; Do not use read syntax #' for `tramp-archive-file-name-handler', it
+ ;; isn't autoloaded.
(when (and tramp-archive-enabled
(not
(rassq 'tramp-archive-file-name-handler
file-name-handler-alist)))
@@ -443,7 +445,7 @@ arguments to pass to the OPERATION."
(and (tramp-archive-file-name-p name)
(match-string 2 name)))
-(defvar tramp-archive-hash (make-hash-table :test 'equal)
+(defvar tramp-archive-hash (make-hash-table :test #'equal)
"Hash table for archive local copies.
The hash key is the archive name. The value is a cons of the
used `tramp-file-name' structure for tramp-gvfs, and the file
diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el
index 25123a6e282..225a26ad1cd 100644
--- a/lisp/net/tramp-cache.el
+++ b/lisp/net/tramp-cache.el
@@ -144,7 +144,6 @@ If KEY is `tramp-cache-undefined', don't create anything,
and return nil."
(defun tramp-get-file-property (key file property &optional default)
"Get the PROPERTY of FILE from the cache context of KEY.
Return DEFAULT if not set."
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(if (eq key tramp-cache-undefined) default
(let* ((hash (tramp-get-hash-table key))
@@ -191,7 +190,6 @@ Return DEFAULT if not set."
(defun tramp-set-file-property (key file property value)
"Set the PROPERTY of FILE to VALUE, in the cache context of KEY.
Return VALUE."
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(if (eq key tramp-cache-undefined) value
(let ((hash (tramp-get-hash-table key)))
@@ -224,7 +222,6 @@ Return VALUE."
;;;###tramp-autoload
(defun tramp-flush-file-property (key file property)
"Remove PROPERTY of FILE in the cache context of KEY."
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(unless (eq key tramp-cache-undefined)
(remhash property (tramp-get-hash-table key))
@@ -239,7 +236,6 @@ Return VALUE."
;; `file-name-directory' can return nil, for example for "~".
(when-let ((file (file-name-directory file))
(file (directory-file-name file)))
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(unless (eq key tramp-cache-undefined)
(dolist (property (hash-table-keys (tramp-get-hash-table key)))
@@ -254,7 +250,6 @@ Return VALUE."
(defun tramp-flush-file-properties (key file)
"Remove all properties of FILE in the cache context of KEY."
(let ((truename (tramp-get-file-property key file "file-truename")))
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
(setq key (tramp-file-name-unify key file))
(unless (eq key tramp-cache-undefined)
(tramp-message key 8 "%s" (tramp-file-name-localname key))
@@ -338,17 +333,15 @@ FILE must be a local file name on a connection identified
via KEY."
"Save PROPERTY, run BODY, reset PROPERTY.
Preserve timestamps."
(declare (indent 3) (debug t))
- `(progn
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
- (setf ,key (tramp-file-name-unify ,key ,file))
- (let* ((hash (tramp-get-hash-table ,key))
- (cached (and (hash-table-p hash) (gethash ,property hash))))
- (unwind-protect (progn ,@body)
- ;; Reset PROPERTY. Recompute hash, it could have been flushed.
- (setq hash (tramp-get-hash-table ,key))
- (if (consp cached)
- (puthash ,property cached hash)
- (remhash ,property hash))))))
+ `(let* ((key (tramp-file-name-unify ,key ,file))
+ (hash (tramp-get-hash-table key))
+ (cached (and (hash-table-p hash) (gethash ,property hash))))
+ (unwind-protect (progn ,@body)
+ ;; Reset PROPERTY. Recompute hash, it could have been flushed.
+ (setq hash (tramp-get-hash-table key))
+ (if (consp cached)
+ (puthash ,property cached hash)
+ (remhash ,property hash)))))
;;;###tramp-autoload
(defmacro with-tramp-saved-file-properties (key file properties &rest body)
@@ -356,22 +349,20 @@ Preserve timestamps."
PROPERTIES is a list of file properties (strings).
Preserve timestamps."
(declare (indent 3) (debug t))
- `(progn
- ;; Unify localname. Remove hop from `tramp-file-name' structure.
- (setf ,key (tramp-file-name-unify ,key ,file))
- (let* ((hash (tramp-get-hash-table ,key))
- (values
- (and (hash-table-p hash)
- (mapcar
- (lambda (property) (cons property (gethash property hash)))
- ,properties))))
- (unwind-protect (progn ,@body)
- ;; Reset PROPERTIES. Recompute hash, it could have been flushed.
- (setq hash (tramp-get-hash-table ,key))
- (dolist (value values)
- (if (consp (cdr value))
- (puthash (car value) (cdr value) hash)
- (remhash (car value) hash)))))))
+ `(let* ((key (tramp-file-name-unify ,key ,file))
+ (hash (tramp-get-hash-table key))
+ (values
+ (and (hash-table-p hash)
+ (mapcar
+ (lambda (property) (cons property (gethash property hash)))
+ ,properties))))
+ (unwind-protect (progn ,@body)
+ ;; Reset PROPERTIES. Recompute hash, it could have been flushed.
+ (setq hash (tramp-get-hash-table key))
+ (dolist (value values)
+ (if (consp (cdr value))
+ (puthash (car value) (cdr value) hash)
+ (remhash (car value) hash))))))
;;; -- Properties --
@@ -473,38 +464,36 @@ used to cache connection properties of the local machine."
(defmacro with-tramp-saved-connection-property (key property &rest body)
"Save PROPERTY, run BODY, reset PROPERTY."
(declare (indent 2) (debug t))
- `(progn
- (setf ,key (tramp-file-name-unify ,key))
- (let* ((hash (tramp-get-hash-table ,key))
- (cached (and (hash-table-p hash)
- (gethash ,property hash tramp-cache-undefined))))
- (unwind-protect (progn ,@body)
- ;; Reset PROPERTY. Recompute hash, it could have been flushed.
- (setq hash (tramp-get-hash-table ,key))
- (if (not (eq cached tramp-cache-undefined))
- (puthash ,property cached hash)
- (remhash ,property hash))))))
+ `(let* ((key (tramp-file-name-unify ,key))
+ (hash (tramp-get-hash-table key))
+ (cached (and (hash-table-p hash)
+ (gethash ,property hash tramp-cache-undefined))))
+ (unwind-protect (progn ,@body)
+ ;; Reset PROPERTY. Recompute hash, it could have been flushed.
+ (setq hash (tramp-get-hash-table key))
+ (if (not (eq cached tramp-cache-undefined))
+ (puthash ,property cached hash)
+ (remhash ,property hash)))))
;;;###tramp-autoload
(defmacro with-tramp-saved-connection-properties (key properties &rest body)
"Save PROPERTIES, run BODY, reset PROPERTIES.
PROPERTIES is a list of file properties (strings)."
(declare (indent 2) (debug t))
- `(progn
- (setf ,key (tramp-file-name-unify ,key))
- (let* ((hash (tramp-get-hash-table ,key))
- (values
- (mapcar
- (lambda (property)
- (cons property (gethash property hash tramp-cache-undefined)))
- ,properties)))
- (unwind-protect (progn ,@body)
- ;; Reset PROPERTIES. Recompute hash, it could have been flushed.
- (setq hash (tramp-get-hash-table ,key))
- (dolist (value values)
- (if (not (eq (cdr value) tramp-cache-undefined))
- (puthash (car value) (cdr value) hash)
- (remhash (car value) hash)))))))
+ `(let* ((key (tramp-file-name-unify ,key))
+ (hash (tramp-get-hash-table key))
+ (values
+ (mapcar
+ (lambda (property)
+ (cons property (gethash property hash tramp-cache-undefined)))
+ ,properties)))
+ (unwind-protect (progn ,@body)
+ ;; Reset PROPERTIES. Recompute hash, it could have been flushed.
+ (setq hash (tramp-get-hash-table key))
+ (dolist (value values)
+ (if (not (eq (cdr value) tramp-cache-undefined))
+ (puthash (car value) (cdr value) hash)
+ (remhash (car value) hash))))))
;;;###tramp-autoload
(defun tramp-cache-print (table)
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el
index 87b20b982f9..98de0dba7ff 100644
--- a/lisp/net/tramp-compat.el
+++ b/lisp/net/tramp-compat.el
@@ -309,7 +309,7 @@ Also see `ignore'."
;; Macro `connection-local-p' is new in Emacs 30.1.
(if (macrop 'connection-local-p)
- (defalias 'tramp-compat-connection-local-p #'connection-local-p)
+ (defalias 'tramp-compat-connection-local-p 'connection-local-p)
(defmacro tramp-compat-connection-local-p (variable)
"Non-nil if VARIABLE has a connection-local binding in
`default-directory'."
`(let (connection-local-variables-alist file-local-variables-alist)
@@ -337,6 +337,8 @@ Also see `ignore'."
;;
;; * Starting with Emacs 29.1, use `buffer-match-p'.
;;
+;; * Starting with Emacs 29.1, use `string-split'.
+;;
;; * Starting with Emacs 30.1, there is `handler-bind'. Use it
;; instead of `condition-case' when the origin of an error shall be
;; kept, for example when the HANDLER propagates the error with
diff --git a/lisp/net/tramp-container.el b/lisp/net/tramp-container.el
index 1f578949e4d..30639cbeb85 100644
--- a/lisp/net/tramp-container.el
+++ b/lisp/net/tramp-container.el
@@ -31,15 +31,20 @@
;; Open a file on a running Docker container:
;;
;; C-x C-f /docker:USER@CONTAINER:/path/to/file
+;; C-x C-f /dockercp:USER@CONTAINER:/path/to/file
;;
;; or Podman:
;;
;; C-x C-f /podman:USER@CONTAINER:/path/to/file
+;; C-x C-f /podmancp:USER@CONTAINER:/path/to/file
;;
;; Where:
;; USER is the user on the container to connect as (optional).
;; CONTAINER is the container to connect to.
;;
+;; "docker" and "podman" are inline methods, "dockercp" and "podmancp"
+;; are out-of-band methods.
+;;
;;
;;
;; Open file in a Kubernetes container:
@@ -141,10 +146,20 @@ If it is nil, the default context will be used."
(defconst tramp-docker-method "docker"
"Tramp method name to use to connect to Docker containers.")
+;;;###tramp-autoload
+(defconst tramp-dockercp-method "dockercp"
+ "Tramp method name to use to connect to Docker containers.
+This is for out-of-band connections.")
+
;;;###tramp-autoload
(defconst tramp-podman-method "podman"
"Tramp method name to use to connect to Podman containers.")
+;;;###tramp-autoload
+(defconst tramp-podmancp-method "podmancp"
+ "Tramp method name to use to connect to Podman containers.
+This is for out-of-band connections.")
+
;;;###tramp-autoload
(defconst tramp-kubernetes-method "kubernetes"
"Tramp method name to use to connect to Kubernetes containers.")
@@ -183,7 +198,8 @@ BODY is the backend specific code."
(defun tramp-container--completion-function (method)
"List running containers available for connection.
METHOD is the Tramp method to be used for \"ps\", either
-`tramp-docker-method' or `tramp-podman-method'.
+`tramp-docker-method', `tramp-dockercp-method', `tramp-podman-method',
+or `tramp-podmancp-method'.
This function is used by `tramp-set-completion-function', please
see its function help for a description of the format."
@@ -375,6 +391,23 @@ see its function help for a description of the format."
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-i" "-c"))))
+ (add-to-list 'tramp-methods
+ `(,tramp-dockercp-method
+ (tramp-login-program ,tramp-docker-program)
+ (tramp-login-args (("exec")
+ ("-it")
+ ("-u" "%u")
+ ("%h")
+ ("%l")))
+ (tramp-direct-async (,tramp-default-remote-shell "-c"))
+ (tramp-remote-shell ,tramp-default-remote-shell)
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-i" "-c"))
+ (tramp-copy-program ,tramp-docker-program)
+ (tramp-copy-args (("cp")))
+ (tramp-copy-file-name (("%h" ":") ("%f")))
+ (tramp-copy-recursive t)))
+
(add-to-list 'tramp-methods
`(,tramp-podman-method
(tramp-login-program ,tramp-podman-program)
@@ -388,6 +421,23 @@ see its function help for a description of the format."
(tramp-remote-shell-login ("-l"))
(tramp-remote-shell-args ("-i" "-c"))))
+ (add-to-list 'tramp-methods
+ `(,tramp-podmancp-method
+ (tramp-login-program ,tramp-podman-program)
+ (tramp-login-args (("exec")
+ ("-it")
+ ("-u" "%u")
+ ("%h")
+ ("%l")))
+ (tramp-direct-async (,tramp-default-remote-shell "-c"))
+ (tramp-remote-shell ,tramp-default-remote-shell)
+ (tramp-remote-shell-login ("-l"))
+ (tramp-remote-shell-args ("-i" "-c"))
+ (tramp-copy-program ,tramp-podman-program)
+ (tramp-copy-args (("cp")))
+ (tramp-copy-file-name (("%h" ":") ("%f")))
+ (tramp-copy-recursive t)))
+
(add-to-list 'tramp-methods
`(,tramp-kubernetes-method
(tramp-login-program ,tramp-kubernetes-program)
@@ -431,10 +481,18 @@ see its function help for a description of the format."
tramp-docker-method
`((tramp-container--completion-function ,tramp-docker-method)))
+ (tramp-set-completion-function
+ tramp-dockercp-method
+ `((tramp-container--completion-function ,tramp-dockercp-method)))
+
(tramp-set-completion-function
tramp-podman-method
`((tramp-container--completion-function ,tramp-podman-method)))
+ (tramp-set-completion-function
+ tramp-podmancp-method
+ `((tramp-container--completion-function ,tramp-podmancp-method)))
+
(tramp-set-completion-function
tramp-kubernetes-method
`((tramp-kubernetes--completion-function ,tramp-kubernetes-method)))
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 72589e7ce4a..93071ed7350 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -888,7 +888,8 @@ Operations not mentioned here will be handled by the
default Emacs primitives.")
"Invoke the GVFS related OPERATION and ARGS.
First arg specifies the OPERATION, second arg is a list of
arguments to pass to the OPERATION."
- (unless tramp-gvfs-enabled
+ ;; `file-remote-p' must not return an error. (Bug#68976)
+ (unless (or tramp-gvfs-enabled (eq operation 'file-remote-p))
(tramp-user-error nil "Package `tramp-gvfs' not supported"))
(if-let ((filename (apply #'tramp-file-name-for-operation operation args))
(tramp-gvfs-dbus-event-vector
@@ -2293,8 +2294,8 @@ connection if a previous connection has died for some
reason."
;; indicated by the "mounted" signal, i.e. the
;; "fuse-mountpoint" file property.
(with-timeout
- ((or (tramp-get-method-parameter vec 'tramp-connection-timeout)
- tramp-connection-timeout)
+ ((tramp-get-method-parameter
+ vec 'tramp-connection-timeout tramp-connection-timeout)
(if (tramp-string-empty-or-nil-p (tramp-file-name-user vec))
(tramp-error
vec 'file-error
diff --git a/lisp/net/tramp-integration.el b/lisp/net/tramp-integration.el
index c0b60f57e40..e1f0b2a3495 100644
--- a/lisp/net/tramp-integration.el
+++ b/lisp/net/tramp-integration.el
@@ -69,7 +69,7 @@ special handling of `substitute-in-file-name'."
(when minibuffer-completing-file-name
(setq tramp-rfn-eshadow-overlay
(make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end)))
- ;; Copy rfn-eshadow-overlay properties.
+ ;; Copy `rfn-eshadow-overlay' properties.
(let ((props (overlay-properties rfn-eshadow-overlay)))
(while props
;; The `field' property prevents correct minibuffer
diff --git a/lisp/net/tramp-message.el b/lisp/net/tramp-message.el
index 96071e626a5..97e94a51e7a 100644
--- a/lisp/net/tramp-message.el
+++ b/lisp/net/tramp-message.el
@@ -353,6 +353,7 @@ applicable)."
If VEC-OR-PROC is nil, the buffer *debug tramp* is used. FORCE
forces the backtrace even if `tramp-verbose' is less than 10.
This function is meant for debugging purposes."
+ (declare (tramp-suppress-trace t))
(let ((tramp-verbose (if force 10 tramp-verbose)))
(when (>= tramp-verbose 10)
(tramp-message
@@ -364,6 +365,7 @@ VEC-OR-PROC identifies the connection to use, SIGNAL is the
signal identifier to be raised, remaining arguments passed to
`tramp-message'. Finally, signal SIGNAL is raised with
FMT-STRING and ARGUMENTS."
+ (declare (tramp-suppress-trace t))
(let (signal-hook-function)
(tramp-backtrace vec-or-proc)
(unless arguments
@@ -391,6 +393,7 @@ tramp-tests.el.")
"Emit an error, and show BUF.
If BUF is nil, show the connection buf. Wait for 30\", or until
an input event arrives. The other arguments are passed to `tramp-error'."
+ (declare (tramp-suppress-trace t))
(save-window-excursion
(let* ((buf (or (and (bufferp buf) buf)
(and (processp vec-or-proc) (process-buffer vec-or-proc))
@@ -424,6 +427,7 @@ an input event arrives. The other arguments are passed to
`tramp-error'."
(defsubst tramp-user-error (vec-or-proc fmt-string &rest arguments)
"Signal a user error (or \"pilot error\")."
+ (declare (tramp-suppress-trace t))
(unwind-protect
(apply #'tramp-error vec-or-proc 'user-error fmt-string arguments)
;; Save exit.
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 6bb1d976ec5..66e648624b2 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -38,7 +38,6 @@
(declare-function dired-compress-file "dired-aux")
(declare-function dired-remove-file "dired-aux")
(defvar dired-compress-file-suffixes)
-(defvar ls-lisp-use-insert-directory-program)
;; Added in Emacs 28.1.
(defvar process-file-return-signal-string)
(defvar vc-handled-backends)
@@ -283,6 +282,7 @@ The string is used in `tramp-methods'.")
(tramp-copy-program "nc")
;; We use "-v" for better error tracking.
(tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r")))
+ (tramp-copy-file-name (("%f")))
(tramp-remote-copy-program "nc")
;; We use "-p" as required for newer busyboxes. For older
;; busybox/nc versions, the value must be (("-l") ("%r")).
This
@@ -429,6 +429,9 @@ The string is used in `tramp-methods'.")
eos)
nil ,(user-login-name))))
+(defconst tramp-default-copy-file-name '(("%u" "@") ("%h" ":") ("%f"))
+ "Default `tramp-copy-file-name' entry for out-of-band methods.")
+
;;;###tramp-autoload
(defconst tramp-completion-function-alist-rsh
'((tramp-parse-rhosts "/etc/hosts.equiv")
@@ -548,6 +551,7 @@ shell from reading its init file."
(tramp-terminal-prompt-regexp tramp-action-terminal)
(tramp-antispoof-regexp tramp-action-confirm-message)
(tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message)
+ (tramp-security-key-pin-regexp tramp-action-otp-password)
(tramp-process-alive-regexp tramp-action-process-alive))
"List of pattern/action pairs.
Whenever a pattern matches, the corresponding action is performed.
@@ -567,6 +571,7 @@ corresponding PATTERN matches, the ACTION function is
called.")
(tramp-wrong-passwd-regexp tramp-action-permission-denied)
(tramp-copy-failed-regexp tramp-action-permission-denied)
(tramp-security-key-confirm-regexp tramp-action-show-and-confirm-message)
+ (tramp-security-key-pin-regexp tramp-action-otp-password)
(tramp-process-alive-regexp tramp-action-out-of-band))
"List of pattern/action pairs.
This list is used for copying/renaming with out-of-band methods.
@@ -2010,7 +2015,7 @@ ID-FORMAT valid values are `string' and `integer'."
#'copy-directory
(list dirname newname keep-date parents copy-contents))))
- ;; When newname did exist, we have wrong cached values.
+ ;; NEWNAME has wrong cached values.
(when t2
(with-parsed-tramp-file-name (expand-file-name newname) nil
(tramp-flush-file-properties v localname)))))))
@@ -2149,24 +2154,24 @@ file names."
;; One of them must be a Tramp file.
(error "Tramp implementation says this cannot happen")))
- ;; Handle `preserve-extended-attributes'. We ignore
- ;; possible errors, because ACL strings could be
- ;; incompatible.
- (when-let ((attributes (and preserve-extended-attributes
- (file-extended-attributes filename))))
- (ignore-errors
- (set-file-extended-attributes newname attributes)))
-
;; In case of `rename', we must flush the cache of the source file.
(when (and t1 (eq op 'rename))
(with-parsed-tramp-file-name filename v1
(tramp-flush-file-properties v1 v1-localname)))
- ;; When newname did exist, we have wrong cached values.
+ ;; NEWNAME has wrong cached values.
(when t2
(with-parsed-tramp-file-name newname v2
(tramp-flush-file-properties v2 v2-localname)))
+ ;; Handle `preserve-extended-attributes'. We ignore
+ ;; possible errors, because ACL strings could be
+ ;; incompatible.
+ (when-let ((attributes (and preserve-extended-attributes
+ (file-extended-attributes filename))))
+ (ignore-errors
+ (set-file-extended-attributes newname attributes)))
+
;; KEEP-DATE handling.
(when (and keep-date (not copy-keep-date))
(tramp-compat-set-file-times
@@ -2398,10 +2403,10 @@ The method used must be an out-of-band method."
#'file-name-as-directory
#'identity)
(if v1
- (tramp-make-copy-program-file-name v1)
+ (tramp-make-copy-file-name v1)
(file-name-unquote filename)))
target (if v2
- (tramp-make-copy-program-file-name v2)
+ (tramp-make-copy-file-name v2)
(file-name-unquote newname)))
;; Check for listener port.
@@ -2438,9 +2443,9 @@ The method used must be an out-of-band method."
copy-program (tramp-get-method-parameter v 'tramp-copy-program)
copy-args
;; " " has either been a replacement of "%k" (when
- ;; keep-date argument is non-nil), or a replacement for
+ ;; KEEP-DATE argument is non-nil), or a replacement for
;; the whole keep-date sublist.
- (delete " " (apply #'tramp-expand-args v 'tramp-copy-args spec))
+ (delete " " (apply #'tramp-expand-args v 'tramp-copy-args nil spec))
;; `tramp-ssh-controlmaster-options' is a string instead
;; of a list. Unflatten it.
copy-args
@@ -2449,11 +2454,11 @@ The method used must be an out-of-band method."
(lambda (x) (if (tramp-compat-string-search " " x)
(split-string x) x))
copy-args))
- copy-env (apply #'tramp-expand-args v 'tramp-copy-env spec)
+ copy-env (apply #'tramp-expand-args v 'tramp-copy-env nil spec)
remote-copy-program
(tramp-get-method-parameter v 'tramp-remote-copy-program)
remote-copy-args
- (apply #'tramp-expand-args v 'tramp-remote-copy-args spec))
+ (apply #'tramp-expand-args v 'tramp-remote-copy-args nil spec))
;; Check for local copy program.
(unless (executable-find copy-program)
@@ -2636,7 +2641,7 @@ The method used must be an out-of-band method."
(defun tramp-sh-handle-insert-directory
(filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
- (if (and (featurep 'ls-lisp)
+ (if (and (boundp 'ls-lisp-use-insert-directory-program)
(not ls-lisp-use-insert-directory-program))
(tramp-handle-insert-directory
filename switches wildcard full-directory-p)
@@ -5289,7 +5294,8 @@ connection if a previous connection has died for some
reason."
(tramp-get-method-parameter hop
'tramp-async-args)))
(connection-timeout
(tramp-get-method-parameter
- hop 'tramp-connection-timeout))
+ hop 'tramp-connection-timeout
+ tramp-connection-timeout))
(command
(tramp-get-method-parameter
hop 'tramp-login-program))
@@ -5347,14 +5353,14 @@ connection if a previous connection has died for some
reason."
;; Add arguments for asynchronous processes.
(when process-name async-args)
(tramp-expand-args
- hop 'tramp-login-args
+ hop 'tramp-login-args nil
?h (or l-host "") ?u (or l-user "") ?p (or l-port "")
?c (format-spec options (format-spec-make ?t tmpfile))
?n (concat
"2>" (tramp-get-remote-null-device previous-hop))
?l (concat remote-shell " " extra-args " -i"))
;; A restricted shell does not allow "exec".
- (when r-shell '("&&" "exit")) '("||" "exit"))
+ (when r-shell '("&&" "exit")) '("||" "exit"))
" "))
;; Send the command.
@@ -5364,8 +5370,7 @@ connection if a previous connection has died for some
reason."
p vec
(min
pos (with-current-buffer (process-buffer p)
(point-max)))
- tramp-actions-before-shell
- (or connection-timeout tramp-connection-timeout))
+ tramp-actions-before-shell connection-timeout)
(tramp-message
vec 3 "Found remote shell prompt on `%s'" l-host)
@@ -5558,8 +5563,8 @@ raises an error."
string
""))
-(defun tramp-make-copy-program-file-name (vec)
- "Create a file name suitable for `scp', `pscp', or `nc' and workalikes."
+(defun tramp-make-copy-file-name (vec)
+ "Create a file name suitable for out-of-band methods."
(let ((method (tramp-file-name-method vec))
(user (tramp-file-name-user vec))
(host (tramp-file-name-host vec))
@@ -5570,13 +5575,13 @@ raises an error."
;; This does not work for MS Windows scp, if there are characters
;; to be quoted. OpenSSH 8 supports disabling of strict file name
;; checking in scp, we use it when available.
- (unless (string-match-p (rx "ftp" eos) method)
+ (unless (string-match-p (rx (| "dockercp" "podmancp" "ftp") eos) method)
(setq localname (tramp-unquote-shell-quote-argument localname)))
- (cond
- ((tramp-get-method-parameter vec 'tramp-remote-copy-program)
- localname)
- ((tramp-string-empty-or-nil-p user) (format "%s:%s" host localname))
- (t (format "%s@%s:%s" user host localname)))))
+ (string-join
+ (apply #'tramp-expand-args vec
+ 'tramp-copy-file-name tramp-default-copy-file-name
+ (list ?h (or host "") ?u (or user "") ?f localname))
+ "")))
(defun tramp-method-out-of-band-p (vec size)
"Return t if this is an out-of-band method, nil otherwise."
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index 8dad599c7e7..d0d56b8967e 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -322,7 +322,7 @@ arguments to pass to the OPERATION."
v (tramp-get-method-parameter v 'tramp-login-program)
nil outbuf display
(tramp-expand-args
- v 'tramp-login-args
+ v 'tramp-login-args nil
?h (or (tramp-file-name-host v) "")
?u (or (tramp-file-name-user v) "")
?p (or (tramp-file-name-port v) "")
@@ -424,7 +424,7 @@ connection if a previous connection has died for some
reason."
(tramp-fuse-mount-spec vec)
(tramp-fuse-mount-point vec)
(tramp-expand-args
- vec 'tramp-mount-args
+ vec 'tramp-mount-args nil
?p (or (tramp-file-name-port vec) ""))))))
(tramp-error
vec 'file-error "Error mounting %s" (tramp-fuse-mount-spec vec)))
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index 0c717c4a5aa..7bbfec62753 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -771,7 +771,7 @@ in case of error, t otherwise."
(tramp-get-connection-name vec) (current-buffer)
(append
(tramp-expand-args
- vec 'tramp-sudo-login
+ vec 'tramp-sudo-login nil
?h (or (tramp-file-name-host vec) "")
?u (or (tramp-file-name-user vec) ""))
(flatten-tree args))))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 74d95757e46..5b101000926 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -67,11 +67,6 @@
(declare-function file-notify-rm-watch "filenotify")
(declare-function netrc-parse "netrc")
(defvar auto-save-file-name-transforms)
-(defvar ls-lisp-dirs-first)
-(defvar ls-lisp-emulation)
-(defvar ls-lisp-ignore-case)
-(defvar ls-lisp-use-insert-directory-program)
-(defvar ls-lisp-verbosity)
(defvar tramp-prefix-format)
(defvar tramp-prefix-regexp)
(defvar tramp-method-regexp)
@@ -306,6 +301,15 @@ pair of the form (KEY VALUE). The following KEYs are
defined:
This specifies the list of parameters to pass to the above mentioned
program, the hints for `tramp-login-args' also apply here.
+ * `tramp-copy-file-name'
+ The remote source or destination file name for out-of-band methods.
+ You can use \"%u\" and \"%h\" like in `tramp-login-args'.
+ Additionally, \"%f\" denotes the local file name part. This list
+ will be expanded to a string without spaces between the elements of
+ the list.
+
+ The default value is `tramp-default-copy-file-name'.
+
* `tramp-copy-env'
A list of environment variables and their values, which will
be set when calling `tramp-copy-program'.
@@ -320,8 +324,8 @@ pair of the form (KEY VALUE). The following KEYs are
defined:
chosen port for the remote listener.
* `tramp-copy-keep-date'
- This specifies whether the copying program when the preserves the
- timestamp of the original file.
+ This specifies whether the copying program preserves the timestamp
+ of the original file.
* `tramp-copy-keep-tmpfile'
This specifies whether a temporary local file shall be kept
@@ -562,7 +566,7 @@ host runs a restricted shell, it shall be added to this
list, too."
eos)
"Host names which are regarded as local host.
If the local host runs a chrooted environment, set this to nil."
- :version "30.1"
+ :version "29.3"
:type '(choice (const :tag "Chrooted environment" nil)
(regexp :tag "Host regexp")))
@@ -750,9 +754,8 @@ The regexp should match at end of buffer."
;; A security key requires the user physically to touch the device
;; with their finger. We must tell it to the user.
-;; Added in OpenSSH 8.2. I've tested it with yubikey. Nitrokey and
-;; Titankey, which have also passed the tests, do not show such a
-;; message.
+;; Added in OpenSSH 8.2. I've tested it with Nitrokey, Titankey, and
+;; Yubikey.
(defcustom tramp-security-key-confirm-regexp
(rx bol (* "\r") "Confirm user presence for key " (* nonl) (* (any "\r\n")))
"Regular expression matching security key confirmation message.
@@ -775,6 +778,14 @@ The regexp should match at end of buffer."
:version "28.1"
:type 'regexp)
+;; Needed only for FIDO2 (residential) keys. Tested with Nitrokey and Yubikey.
+(defcustom tramp-security-key-pin-regexp
+ (rx bol (* "\r") (group "Enter PIN for " (* nonl)) (* (any "\r\n")))
+ "Regular expression matching security key PIN prompt.
+The regexp should match at end of buffer."
+ :version "29.3"
+ :type 'regexp)
+
(defcustom tramp-operation-not-permitted-regexp
(rx (| (: "preserving times" (* nonl)) "set mode") ":" (* blank)
"Operation not permitted")
@@ -1543,21 +1554,23 @@ LOCALNAME and HOP do not count."
(equal (tramp-file-name-unify vec1)
(tramp-file-name-unify vec2))))
-(defun tramp-get-method-parameter (vec param)
+(defun tramp-get-method-parameter (vec param &optional default)
"Return the method parameter PARAM.
If VEC is a vector, check first in connection properties.
Afterwards, check in `tramp-methods'. If the `tramp-methods'
-entry does not exist, return nil."
+entry does not exist, return DEFAULT."
(let ((hash-entry
(replace-regexp-in-string (rx bos "tramp-") "" (symbol-name param))))
(if (tramp-connection-property-p vec hash-entry)
;; We use the cached property.
(tramp-get-connection-property vec hash-entry)
;; Use the static value from `tramp-methods'.
- (when-let ((methods-entry
+ (if-let ((methods-entry
(assoc
param (assoc (tramp-file-name-method vec) tramp-methods))))
- (cadr methods-entry)))))
+ (cadr methods-entry)
+ ;; Return the default value.
+ default))))
;; The localname can be quoted with "/:". Extract this.
(defun tramp-file-name-unquote-localname (vec)
@@ -3941,6 +3954,9 @@ Let-bind it when necessary.")
(tramp-get-method-parameter v 'tramp-case-insensitive)
;; There isn't. So we must check, in case there's a connection already.
+ ;; Note: We cannot use it as DEFAULT value of
+ ;; `tramp-get-method-parameter', because it would be evalled
+ ;; during the call.
(and (let ((non-essential t)) (tramp-connectable-p v))
(with-tramp-connection-property v "case-insensitive"
(ignore-errors
@@ -4189,6 +4205,11 @@ Let-bind it when necessary.")
(filename switches &optional wildcard full-directory-p)
"Like `insert-directory' for Tramp files."
(require 'ls-lisp)
+ (defvar ls-lisp-dirs-first)
+ (defvar ls-lisp-emulation)
+ (defvar ls-lisp-ignore-case)
+ (defvar ls-lisp-use-insert-directory-program)
+ (defvar ls-lisp-verbosity)
(unless switches (setq switches ""))
;; Mark trailing "/".
(when (and (directory-name-p filename)
@@ -4745,15 +4766,15 @@ Do not set it manually, it is used buffer-local in
`tramp-get-lock-pid'.")
(defvar tramp-extra-expand-args nil
"Method specific arguments.")
-(defun tramp-expand-args (vec parameter &rest spec-list)
+(defun tramp-expand-args (vec parameter default &rest spec-list)
"Expand login arguments as given by PARAMETER in `tramp-methods'.
PARAMETER is a symbol like `tramp-login-args', denoting a list of
list of strings from `tramp-methods', containing %-sequences for
-substitution.
+substitution. DEFAULT is used when PARAMETER is not specified.
SPEC-LIST is a list of char/value pairs used for
`format-spec-make'. It is appended by `tramp-extra-expand-args',
a connection-local variable."
- (let ((args (tramp-get-method-parameter vec parameter))
+ (let ((args (tramp-get-method-parameter vec parameter default))
(extra-spec-list
(mapcar
#'eval
@@ -4932,7 +4953,7 @@ a connection-local variable."
(mapcar
(lambda (x) (split-string x " "))
(tramp-expand-args
- v 'tramp-login-args
+ v 'tramp-login-args nil
?h (or host "") ?u (or user "") ?p (or port "")
?c (format-spec (or options "") (format-spec-make ?t tmpfile))
?d (or device "") ?a (or pta "") ?l ""))))
@@ -5435,7 +5456,7 @@ of."
prompt)
(goto-char (point-min))
(tramp-check-for-regexp proc tramp-process-action-regexp)
- (setq prompt (concat (match-string 1) " "))
+ (setq prompt (concat (string-trim (match-string 1)) " "))
(tramp-message vec 3 "Sending %s" (match-string 1))
;; We don't call `tramp-send-string' in order to hide the
;; password from the debug buffer and the traces.
@@ -5511,14 +5532,16 @@ Wait, until the connection buffer changes."
(ignore set-message-function clear-message-function)
(tramp-message vec 6 "\n%s" (buffer-string))
(tramp-check-for-regexp proc tramp-process-action-regexp)
- (with-temp-message
- (replace-regexp-in-string (rx (any "\r\n")) "" (match-string 0))
+ (with-temp-message (concat (string-trim (match-string 0)) " ")
;; Hide message in buffer.
(narrow-to-region (point-max) (point-max))
;; Wait for new output.
(while (not (ignore-error file-error
(tramp-wait-for-regexp
- proc 0.1 tramp-security-key-confirmed-regexp)))
+ proc 0.1
+ (rx (| (regexp tramp-security-key-confirmed-regexp)
+ (regexp tramp-security-key-pin-regexp)
+ (regexp tramp-security-key-timeout-regexp))))))
(when (tramp-check-for-regexp proc
tramp-security-key-timeout-regexp)
(throw 'tramp-action 'timeout))
(redisplay 'force))))))
@@ -6317,9 +6340,8 @@ This handles also chrooted environments, which are not
regarded as local."
(defun tramp-get-remote-tmpdir (vec)
"Return directory for temporary files on the remote host identified by VEC."
(with-tramp-connection-property (tramp-get-process vec) "remote-tmpdir"
- (let ((dir
- (tramp-make-tramp-file-name
- vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp"))))
+ (let ((dir (tramp-make-tramp-file-name
+ vec (tramp-get-method-parameter vec 'tramp-tmpdir "/tmp"))))
(or (and (file-directory-p dir) (file-writable-p dir)
(tramp-file-local-name dir))
(tramp-error vec 'file-error "Directory %s not accessible" dir))
@@ -6564,12 +6586,13 @@ Consults the auth-source package."
(tramp-get-connection-property key "login-as")))
(host (tramp-file-name-host-port vec))
(pw-prompt
- (or prompt
- (with-current-buffer (process-buffer proc)
- (tramp-check-for-regexp proc tramp-password-prompt-regexp)
- (if (string-match-p "passphrase" (match-string 1))
- (match-string 0)
- (format "%s for %s " (capitalize (match-string 1)) key)))))
+ (string-trim-left
+ (or prompt
+ (with-current-buffer (process-buffer proc)
+ (tramp-check-for-regexp proc tramp-password-prompt-regexp)
+ (if (string-match-p "passphrase" (match-string 1))
+ (match-string 0)
+ (format "%s for %s " (capitalize (match-string 1)) key))))))
(auth-source-creation-prompts `((secret . ,pw-prompt)))
;; Use connection-local value.
(auth-sources (buffer-local-value 'auth-sources (process-buffer proc)))
diff --git a/lisp/obarray.el b/lisp/obarray.el
index a26992df8e2..e6e51c1382a 100644
--- a/lisp/obarray.el
+++ b/lisp/obarray.el
@@ -27,24 +27,12 @@
;;; Code:
-(defconst obarray-default-size 59
- "The value 59 is an arbitrary prime number that gives a good hash.")
-
-(defun obarray-make (&optional size)
- "Return a new obarray of size SIZE or `obarray-default-size'."
- (let ((size (or size obarray-default-size)))
- (if (< 0 size)
- (make-vector size 0)
- (signal 'wrong-type-argument '(size 0)))))
-
-(defun obarray-size (ob)
- "Return the number of slots of obarray OB."
- (length ob))
-
-(defun obarrayp (object)
- "Return t if OBJECT is an obarray."
- (and (vectorp object)
- (< 0 (length object))))
+(defconst obarray-default-size 4)
+(make-obsolete-variable 'obarray-default-size
+ "obarrays now grow automatically" "30.1")
+
+(defun obarray-size (_ob) obarray-default-size)
+(make-obsolete 'obarray-size "obarrays now grow automatically" "30.1")
;; Don’t use obarray as a variable name to avoid shadowing.
(defun obarray-get (ob name)
diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el
index 3f05b7fe7ac..e1ea9141f0d 100644
--- a/lisp/obsolete/iswitchb.el
+++ b/lisp/obsolete/iswitchb.el
@@ -370,7 +370,7 @@ See documentation of `walk-windows' for useful values."
This hook is run during minibuffer setup if `iswitchb' is active.
For instance:
\(add-hook \\='iswitchb-minibuffer-setup-hook
- \\='\(lambda () (set (make-local-variable \\='max-mini-window-height)
3)))
+ \\='\(lambda () (setq-local max-mini-window-height 3)))
will constrain the minibuffer to a maximum height of 3 lines when
iswitchb is running."
:type 'hook)
@@ -1262,7 +1262,7 @@ Modified from `icomplete-completions'."
"Set up minibuffer for `iswitchb-buffer'.
Copied from `icomplete-minibuffer-setup-hook'."
(when (iswitchb-entryfn-p)
- (set (make-local-variable 'iswitchb-use-mycompletion) t)
+ (setq-local iswitchb-use-mycompletion t)
(add-hook 'pre-command-hook #'iswitchb-pre-command nil t)
(add-hook 'post-command-hook #'iswitchb-post-command nil t)
(run-hooks 'iswitchb-minibuffer-setup-hook)))
diff --git a/lisp/obsolete/longlines.el b/lisp/obsolete/longlines.el
index 6aa388805f2..f065bcaff26 100644
--- a/lisp/obsolete/longlines.el
+++ b/lisp/obsolete/longlines.el
@@ -116,17 +116,14 @@ newlines are indicated with a symbol."
;; Turn on longlines mode
(progn
(use-hard-newlines 1 'never)
- (set (make-local-variable 'require-final-newline) nil)
+ (setq-local require-final-newline nil)
(add-to-list 'buffer-file-format 'longlines)
(add-hook 'change-major-mode-hook #'longlines-mode-off nil t)
(add-hook 'before-revert-hook #'longlines-before-revert-hook nil t)
(make-local-variable 'longlines-auto-wrap)
- (set (make-local-variable 'isearch-search-fun-function)
- #'longlines-search-function)
- (set (make-local-variable 'replace-search-function)
- #'longlines-search-forward)
- (set (make-local-variable 'replace-re-search-function)
- #'longlines-re-search-forward)
+ (setq-local isearch-search-fun-function #'longlines-search-function)
+ (setq-local replace-search-function #'longlines-search-forward)
+ (setq-local replace-re-search-function #'longlines-re-search-forward)
(add-function :filter-return (local 'filter-buffer-substring-function)
#'longlines-encode-string)
(when longlines-wrap-follows-window-size
@@ -136,8 +133,7 @@ newlines are indicated with a symbol."
(window-width)))
longlines-wrap-follows-window-size
2)))
- (set (make-local-variable 'fill-column)
- (- (window-width) dw)))
+ (setq-local fill-column (- (window-width) dw)))
(add-hook 'window-configuration-change-hook
#'longlines-window-change-function nil t))
(let ((buffer-undo-list t)
diff --git a/lisp/obsolete/pgg.el b/lisp/obsolete/pgg.el
index 6c00ad201f1..4c7b653155e 100644
--- a/lisp/obsolete/pgg.el
+++ b/lisp/obsolete/pgg.el
@@ -85,9 +85,9 @@ is true, or else the output buffer is displayed."
(set-buffer standard-output)
(insert-buffer-substring pgg-errors-buffer))))
-(defvar pgg-passphrase-cache (make-vector 7 0))
+(defvar pgg-passphrase-cache (obarray-make 7))
-(defvar pgg-pending-timers (make-vector 7 0)
+(defvar pgg-pending-timers (obarray-make 7)
"Hash table for managing scheduled pgg cache management timers.
We associate key and timer, so the timer can be canceled if a new
diff --git a/lisp/obsolete/rcompile.el b/lisp/obsolete/rcompile.el
index e0826475e32..258b2b519d9 100644
--- a/lisp/obsolete/rcompile.el
+++ b/lisp/obsolete/rcompile.el
@@ -169,12 +169,12 @@ See \\[compile]."
;; compilation-parse-errors will find referenced files by Tramp.
(with-current-buffer next-error-last-buffer
(when (fboundp 'tramp-make-tramp-file-name)
- (set (make-local-variable 'comint-file-name-prefix)
- (funcall
- #'tramp-make-tramp-file-name
- nil ;; method.
- remote-compile-user
- remote-compile-host
- ""))))))
+ (setq-local comint-file-name-prefix
+ (funcall
+ #'tramp-make-tramp-file-name
+ nil ;; method.
+ remote-compile-user
+ remote-compile-host
+ ""))))))
;;; rcompile.el ends here
diff --git a/lisp/org/org.el b/lisp/org/org.el
index 2c5de69a36c..d361408eaca 100644
--- a/lisp/org/org.el
+++ b/lisp/org/org.el
@@ -4685,7 +4685,7 @@ returns non-nil if any of them match."
(if (and (= char ?f) current-file)
(concat "file://" current-file) uri))
"\\'")))))
- (prog1 (memq char '(?y ?n ?! ?d ?\s ?f))
+ (prog1 (memq char '(?y ?! ?d ?\s ?f))
(quit-window t)))))))
(defun org-extract-log-state-settings (x)
diff --git a/lisp/outline.el b/lisp/outline.el
index b50708c1a7b..40a75701cbf 100644
--- a/lisp/outline.el
+++ b/lisp/outline.el
@@ -318,8 +318,8 @@ Using the value `insert' is not recommended in editable
buffers because it modifies them.
When the value is `in-margins', then clickable buttons are
displayed in the margins before the headings.
-When the value is `t', clickable buttons are displayed
-in the buffer before the headings. The values `t' and
+When the value is t, clickable buttons are displayed
+in the buffer before the headings. The values t and
`in-margins' can be used in editing buffers because they
don't modify the buffer."
;; The value `insert' is not intended to be customizable.
@@ -686,7 +686,7 @@ If POS is nil, use `point' instead."
(defun outline-back-to-heading (&optional invisible-ok)
"Move to previous heading line, or beg of this line if it's a heading.
Only visible heading lines are considered, unless INVISIBLE-OK is non-nil."
- (beginning-of-line)
+ (forward-line 0)
(or (outline-on-heading-p invisible-ok)
(let (found)
(save-excursion
@@ -705,7 +705,7 @@ Only visible heading lines are considered, unless
INVISIBLE-OK is non-nil."
"Return t if point is on a (visible) heading line.
If INVISIBLE-OK is non-nil, an invisible heading line is ok too."
(save-excursion
- (beginning-of-line)
+ (forward-line 0)
(and (bolp) (or invisible-ok (not (outline-invisible-p)))
(if outline-search-function
(funcall outline-search-function nil nil nil t)
@@ -725,7 +725,7 @@ If INVISIBLE-OK is non-nil, an invisible heading line is ok
too."
(not (string-match (concat "\\`\\(?:" outline-regexp "\\)")
(concat head " "))))
(setq head (concat head " ")))
- (unless (bolp) (end-of-line) (newline))
+ (unless (bolp) (goto-char (pos-eol)) (newline))
(insert head)
(unless (eolp)
(save-excursion (newline-and-indent)))
@@ -941,9 +941,7 @@ With ARG, repeats or can move backward if negative.
A heading line is one that starts with a `*' (or that
`outline-regexp' matches)."
(interactive "p")
- (if (< arg 0)
- (beginning-of-line)
- (end-of-line))
+ (goto-char (if (< arg 0) (pos-bol) (pos-eol)))
(let ((regexp (unless outline-search-function
(concat "^\\(?:" outline-regexp "\\)")))
found-heading-p)
@@ -963,7 +961,7 @@ A heading line is one that starts with a `*' (or that
(re-search-forward regexp nil 'move)))
(outline-invisible-p (match-beginning 0))))
(setq arg (1- arg)))
- (if found-heading-p (beginning-of-line))))
+ (if found-heading-p (forward-line 0))))
(defun outline-previous-visible-heading (arg)
"Move to the previous heading line.
@@ -980,7 +978,7 @@ This puts point at the start of the current subtree, and
mark at the end."
(let ((beg))
(if (outline-on-heading-p)
;; we are already looking at a heading
- (beginning-of-line)
+ (forward-line 0)
;; else go back to previous heading
(outline-previous-visible-heading 1))
(setq beg (point))
@@ -1183,7 +1181,7 @@ of the current heading, or to 1 if the current line is
not a heading."
(cond
(current-prefix-arg (prefix-numeric-value current-prefix-arg))
((save-excursion
- (beginning-of-line)
+ (forward-line 0)
(if outline-search-function
(funcall outline-search-function nil nil nil t)
(looking-at outline-regexp)))
@@ -1243,7 +1241,7 @@ This also unhides the top heading-less body, if any."
(interactive)
(save-excursion
(outline-back-to-heading)
- (if (not (outline-invisible-p (line-end-position)))
+ (if (not (outline-invisible-p (pos-eol)))
(outline-hide-subtree)
(outline-show-children)
(outline-show-entry))))
@@ -1834,7 +1832,7 @@ With a prefix argument, show headings up to that LEVEL."
(defun outline--insert-button (type)
(with-silent-modifications
(save-excursion
- (beginning-of-line)
+ (forward-line 0)
(let ((icon (nth (if (eq type 'close) 1 0) outline--button-icons))
(o (seq-find (lambda (o) (overlay-get o 'outline-button))
(overlays-at (point)))))
@@ -1842,7 +1840,7 @@ With a prefix argument, show headings up to that LEVEL."
(when (eq outline-minor-mode-use-buttons 'insert)
(let ((inhibit-read-only t))
(insert (apply #'propertize " " (text-properties-at (point))))
- (beginning-of-line)))
+ (forward-line 0)))
(setq o (make-overlay (point) (1+ (point))))
(overlay-put o 'outline-button t)
(overlay-put o 'evaporate t))
@@ -1866,7 +1864,7 @@ With a prefix argument, show headings up to that LEVEL."
(when from
(save-excursion
(goto-char from)
- (setq from (line-beginning-position))))
+ (setq from (pos-bol))))
(outline-map-region
(lambda ()
(let ((close-p (save-excursion
diff --git a/lisp/play/cookie1.el b/lisp/play/cookie1.el
index c8e9d097a5f..c4697a0d3b9 100644
--- a/lisp/play/cookie1.el
+++ b/lisp/play/cookie1.el
@@ -65,7 +65,7 @@
(defconst cookie-delimiter "\n%%\n\\|\n%\n\\|\0"
"Delimiter used to separate cookie file entries.")
-(defvar cookie-cache (make-vector 511 0)
+(defvar cookie-cache (obarray-make 511)
"Cache of cookie files that have already been snarfed.")
(defun cookie-check-file (file)
diff --git a/lisp/proced.el b/lisp/proced.el
index 3435f1ab8cd..7d7de1e2ce3 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -2261,7 +2261,7 @@ If LOG is a string and there are more args, it is
formatted with
those ARGS. Usually the LOG string ends with a \\n.
End each bunch of errors with (proced-log t signal):
this inserts the current time, buffer and signal at the start of the page,
-and \f (formfeed) at the end."
+and \\f (formfeed) at the end."
(let ((obuf (current-buffer)))
(with-current-buffer (get-buffer-create proced-log-buffer)
(goto-char (point-max))
diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el
index e5835bdb62d..4ef17daf876 100644
--- a/lisp/progmodes/c-ts-mode.el
+++ b/lisp/progmodes/c-ts-mode.el
@@ -922,6 +922,17 @@ Return nil if NODE is not a defun node or doesn't have a
name."
name)))
t))
+;;; Outline minor mode
+
+(defun c-ts-mode--outline-predicate (node)
+ "Match outlines on lines with function names."
+ (or (and (equal (treesit-node-type node) "function_declarator")
+ (equal (treesit-node-type (treesit-node-parent node))
+ "function_definition"))
+ ;; DEFUNs in Emacs sources.
+ (and c-ts-mode-emacs-sources-support
+ (c-ts-mode--emacs-defun-p node))))
+
;;; Defun navigation
(defun c-ts-mode--defun-valid-p (node)
@@ -1259,6 +1270,10 @@ BEG and END are described in `treesit-range-rules'."
eos)
c-ts-mode--defun-for-class-in-imenu-p nil))))
+ ;; Outline minor mode
+ (setq-local treesit-outline-predicate
+ #'c-ts-mode--outline-predicate)
+
(setq-local treesit-font-lock-feature-list
c-ts-mode--feature-list))
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el
index f84d95dbc94..2c793c8a99d 100644
--- a/lisp/progmodes/cc-defs.el
+++ b/lisp/progmodes/cc-defs.el
@@ -2425,7 +2425,7 @@ system."
(error "Unknown base mode `%s'" base-mode))
(put mode 'c-fallback-mode base-mode))
-(defvar c-lang-constants (make-vector 151 0))
+(defvar c-lang-constants (obarray-make 151))
;; Obarray used as a cache to keep track of the language constants.
;; The constants stored are those defined by `c-lang-defconst' and the values
;; computed by `c-lang-const'. It's mostly used at compile time but it's not
@@ -2579,7 +2579,8 @@ constant. A file is identified by its base name."
;; dependencies on the `c-lang-const's in VAL.)
(setq val (c--macroexpand-all val))
- (setq bindings `(cons (cons ',assigned-mode (lambda () ,val)) ,bindings)
+ (setq bindings `(cons (cons ',assigned-mode (lambda () nil ,val))
+ ,bindings)
args (cdr args))))
;; Compile in the other files that have provided source
@@ -2630,7 +2631,7 @@ constant. A file is identified by its base name."
;; Clear the evaluated values that depend on this source.
(let ((agenda (get sym 'dependents))
- (visited (make-vector 101 0))
+ (visited (obarray-make 101))
ptr)
(while agenda
(setq sym (car agenda)
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el
index ba0d1d0fc49..ae2389c75c2 100644
--- a/lisp/progmodes/cc-langs.el
+++ b/lisp/progmodes/cc-langs.el
@@ -3511,7 +3511,7 @@ Note that Java specific rules are currently applied to
tell this from
(let* ((alist (c-lang-const c-keyword-member-alist))
kwd lang-const-list
- (obarray (make-vector (* (length alist) 2) 0)))
+ (obarray (obarray-make (* (length alist) 2))))
(while alist
(setq kwd (caar alist)
lang-const-list (cdar alist)
diff --git a/lisp/progmodes/cmake-ts-mode.el b/lisp/progmodes/cmake-ts-mode.el
index 29c9e957d3c..45c4882d873 100644
--- a/lisp/progmodes/cmake-ts-mode.el
+++ b/lisp/progmodes/cmake-ts-mode.el
@@ -193,13 +193,13 @@ Check if a node type is available, then return the right
font lock rules."
'((ERROR) @font-lock-warning-face))
"Tree-sitter font-lock settings for `cmake-ts-mode'.")
-(defun cmake-ts-mode--function-name (node)
- "Return the function name of NODE.
-Return nil if there is no name or if NODE is not a function node."
+(defun cmake-ts-mode--defun-name (node)
+ "Return the defun name of NODE.
+Return nil if there is no name or if NODE is not a defun node."
(pcase (treesit-node-type node)
- ("function_command"
+ ((or "function_def" "macro_def")
(treesit-node-text
- (treesit-search-subtree node "^argument$" nil nil 2)
+ (treesit-search-subtree node "^argument$" nil nil 3)
t))))
;;;###autoload
@@ -216,9 +216,15 @@ Return nil if there is no name or if NODE is not a
function node."
(setq-local comment-end "")
(setq-local comment-start-skip (rx "#" (* (syntax whitespace))))
+ ;; Defuns.
+ (setq-local treesit-defun-type-regexp (rx (or "function" "macro")
+ "_def"))
+ (setq-local treesit-defun-name-function #'cmake-ts-mode--defun-name)
+
;; Imenu.
(setq-local treesit-simple-imenu-settings
- `(("Function" "\\`function_command\\'" nil
cmake-ts-mode--function-name)))
+ `(("Function" "^function_def$")
+ ("Macro" "^macro_def$")))
(setq-local which-func-functions nil)
;; Indent.
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
index 51c81b9d2f6..11d400e145a 100644
--- a/lisp/progmodes/compile.el
+++ b/lisp/progmodes/compile.el
@@ -1890,6 +1890,12 @@ process from additional information inserted by Emacs."
(defvar-local compilation--start-time nil
"The time when the compilation started as returned by `float-time'.")
+(defun compilation--downcase-mode-name (mode)
+ "Downcase the name of major MODE, even if MODE is not a string.
+The function `downcase' will barf if passed the name of a `major-mode'
+which is not a string, but instead a symbol or a list."
+ (downcase (format-mode-line mode)))
+
;;;###autoload
(defun compilation-start (command &optional mode name-function highlight-regexp
continue)
@@ -2081,11 +2087,12 @@ Returns the compilation buffer created."
(get-buffer-process
(with-no-warnings
(comint-exec
- outbuf (downcase mode-name)
+ outbuf (compilation--downcase-mode-name mode-name)
shell-file-name
nil `(,shell-command-switch ,command)))))
- (start-file-process-shell-command (downcase mode-name)
- outbuf command))))
+ (start-file-process-shell-command
+ (compilation--downcase-mode-name mode-name)
+ outbuf command))))
;; Make the buffer's mode line show process state.
(setq mode-line-process
'((:propertize ":%s" face compilation-mode-line-run)
@@ -2790,7 +2797,8 @@ Prefix arg N says how many files to move backwards (or
forwards, if negative)."
(let ((buffer (compilation-find-buffer)))
(if (get-buffer-process buffer)
(interrupt-process (get-buffer-process buffer))
- (error "The %s process is not running" (downcase mode-name)))))
+ (error "The %s process is not running"
+ (compilation--downcase-mode-name mode-name)))))
(defalias 'compile-mouse-goto-error 'compile-goto-error)
diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el
index bfc1742610c..113eed64917 100644
--- a/lisp/progmodes/cperl-mode.el
+++ b/lisp/progmodes/cperl-mode.el
@@ -6557,7 +6557,7 @@ and \"Whitesmith\"."
(let ((option (car setting))
(value (cdr setting)))
(set (make-local-variable option) value)))
- (set (make-local-variable 'cperl-file-style) style))
+ (setq-local cperl-file-style style))
(declare-function Info-find-node "info"
(filename nodename &optional no-going-back strict-case
@@ -6612,14 +6612,13 @@ and \"Whitesmith\"."
read))))
(let ((cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ;
"tr///"
- pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner
+ pos isvar height iniheight frheight buf win iniwin not-loner
max-height char-height buf-list)
(if (string-match "^-[a-zA-Z]$" command)
(setq cmd-desc "^-X[ \t\n]"))
(setq isvar (string-match "^[$@%]" command)
buf (cperl-info-buffer isvar)
- iniwin (selected-window)
- fr1 (window-frame iniwin))
+ iniwin (selected-window))
(set-buffer buf)
(goto-char (point-min))
(or isvar
@@ -6640,11 +6639,7 @@ and \"Whitesmith\"."
(or (not win)
(eq (window-buffer win) buf)
(set-window-buffer win buf))
- (and win (setq fr2 (window-frame win)))
- (if (or (not fr2) (eq fr1 fr2))
- (pop-to-buffer buf)
- (special-display-popup-frame buf) ; Make it visible
- (select-window win))
+ (pop-to-buffer buf)
(goto-char pos) ; Needed (?!).
;; Resize
(setq iniheight (window-height)
diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el
index beba268f923..f341428cac3 100644
--- a/lisp/progmodes/eglot.el
+++ b/lisp/progmodes/eglot.el
@@ -243,7 +243,7 @@ automatically)."
(typescript-mode :language-id "typescript"))
. ("typescript-language-server" "--stdio"))
((bash-ts-mode sh-mode) .
("bash-language-server" "start"))
- ((php-mode phps-mode)
+ ((php-mode phps-mode php-ts-mode)
. ,(eglot-alternatives
'(("phpactor" "language-server")
("php"
"vendor/felixfbecker/language-server/bin/php-language-server.php"))))
@@ -259,7 +259,7 @@ automatically)."
. ("haskell-language-server-wrapper" "--lsp"))
(elm-mode . ("elm-language-server"))
(mint-mode . ("mint" "ls"))
- (kotlin-mode . ("kotlin-language-server"))
+ ((kotlin-mode kotlin-ts-mode) .
("kotlin-language-server"))
((go-mode go-dot-mod-mode go-dot-work-mode
go-ts-mode go-mod-ts-mode)
. ("gopls"))
((R-mode ess-r-mode) . ("R" "--slave" "-e"
@@ -284,6 +284,7 @@ automatically)."
((yaml-ts-mode yaml-mode) .
("yaml-language-server" "--stdio"))
(nix-mode . ,(eglot-alternatives '("nil"
"rnix-lsp" "nixd")))
(nickel-mode . ("nls"))
+ ((nushell-mode nushell-ts-mode) . ("nu"
"--lsp"))
(gdscript-mode . ("localhost" 6008))
((fortran-mode f90-mode) . ("fortls"))
(futhark-mode . ("futhark" "lsp"))
@@ -309,7 +310,10 @@ automatically)."
("vscode-markdown-language-server"
"--stdio"))))
(graphviz-dot-mode . ("dot-language-server"
"--stdio"))
(terraform-mode . ("terraform-ls" "serve"))
- ((uiua-ts-mode uiua-mode) . ("uiua" "lsp")))
+ ((uiua-ts-mode uiua-mode) . ("uiua" "lsp"))
+ (sml-mode
+ . ,(lambda (_interactive project)
+ (list "millet-ls" (project-root
project)))))
"How the command `eglot' guesses the server to start.
An association list of (MAJOR-MODE . CONTACT) pairs. MAJOR-MODE
identifies the buffers that are to be managed by a specific
@@ -590,7 +594,7 @@ It is nil if Eglot is not byte-complied.")
(let ((vec (copy-sequence url-path-allowed-chars)))
(aset vec ?: nil) ;; see github#639
vec)
- "Like `url-path-allows-chars' but more restrictive.")
+ "Like `url-path-allowed-chars' but more restrictive.")
;;; Message verification helpers
diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el
index da0cb96e1cf..8a713bd19a2 100644
--- a/lisp/progmodes/elisp-mode.el
+++ b/lisp/progmodes/elisp-mode.el
@@ -221,7 +221,7 @@ All commands in `lisp-mode-shared-map' are inherited by
this map."
(load (byte-compile-dest-file buffer-file-name)))
(declare-function native-compile "comp")
-(declare-function comp-write-bytecode-file "comp")
+(declare-function comp--write-bytecode-file "comp")
(defun emacs-lisp-native-compile ()
"Native-compile the current buffer's file (if it has changed).
@@ -233,7 +233,7 @@ visited by the current buffer."
(byte-to-native-output-buffer-file nil)
(eln (native-compile buffer-file-name)))
(when eln
- (comp-write-bytecode-file eln))))
+ (comp--write-bytecode-file eln))))
(defun emacs-lisp-native-compile-and-load ()
"Native-compile the current buffer's file (if it has changed), then load it.
@@ -309,7 +309,7 @@ Comments in the form will be lost."
INTERACTIVE non-nil means ask the user for confirmation; this
happens in interactive invocations."
(interactive "p")
- (if lexical-binding
+ (if (and (local-variable-p 'lexical-binding) lexical-binding)
(when interactive
(message "lexical-binding already enabled!")
(ding))
@@ -371,6 +371,12 @@ be used instead.
;; Font-locking support.
+(defun elisp--font-lock-shorthand (_limit)
+ ;; Add faces on shorthands between point and LIMIT.
+ ;; ...
+ ;; Return nil to tell font-lock, that there's nothing left to do.
+ nil)
+
(defun elisp--font-lock-flush-elisp-buffers (&optional file)
;; We're only ever called from after-load-functions, load-in-progress can
;; still be t in case of nested loads.
@@ -1582,9 +1588,6 @@ character)."
(buffer-substring-no-properties beg end))
))))
-
-(defvar elisp--eval-last-sexp-fake-value (make-symbol "t"))
-
(defun eval-sexp-add-defvars (exp &optional pos)
"Prepend EXP with all the `defvar's that precede it in the buffer.
POS specifies the starting position where EXP was found and defaults to point."
@@ -1626,16 +1629,10 @@ integer value is also printed as a character of that
codepoint.
If `eval-expression-debug-on-error' is non-nil, which is the default,
this command arranges for all errors to enter the debugger."
(interactive "P")
- (if (null eval-expression-debug-on-error)
- (values--store-value
- (elisp--eval-last-sexp eval-last-sexp-arg-internal))
- (let ((value
- (let ((debug-on-error elisp--eval-last-sexp-fake-value))
- (cons (elisp--eval-last-sexp eval-last-sexp-arg-internal)
- debug-on-error))))
- (unless (eq (cdr value) elisp--eval-last-sexp-fake-value)
- (setq debug-on-error (cdr value)))
- (car value))))
+ (values--store-value
+ (handler-bind ((error (if eval-expression-debug-on-error
+ #'eval-expression--debug #'ignore)))
+ (elisp--eval-last-sexp eval-last-sexp-arg-internal))))
(defun elisp--eval-defun-1 (form)
"Treat some expressions in FORM specially.
@@ -1694,8 +1691,7 @@ Return the result of evaluation."
;; FIXME: the print-length/level bindings should only be applied while
;; printing, not while evaluating.
(defvar elisp--eval-defun-result)
- (let ((debug-on-error eval-expression-debug-on-error)
- (edebugging edebug-all-defs)
+ (let ((edebugging edebug-all-defs)
elisp--eval-defun-result)
(save-excursion
;; Arrange for eval-region to "read" the (possibly) altered form.
@@ -1774,15 +1770,9 @@ which see."
(defvar edebug-all-defs)
(eval-defun (not edebug-all-defs)))
(t
- (if (null eval-expression-debug-on-error)
- (elisp--eval-defun)
- (let (new-value value)
- (let ((debug-on-error elisp--eval-last-sexp-fake-value))
- (setq value (elisp--eval-defun))
- (setq new-value debug-on-error))
- (unless (eq elisp--eval-last-sexp-fake-value new-value)
- (setq debug-on-error new-value))
- value)))))
+ (handler-bind ((error (if eval-expression-debug-on-error
+ #'eval-expression--debug #'ignore)))
+ (elisp--eval-defun)))))
;;; ElDoc Support
diff --git a/lisp/progmodes/elixir-ts-mode.el b/lisp/progmodes/elixir-ts-mode.el
index b493195eedd..f26c3a49203 100644
--- a/lisp/progmodes/elixir-ts-mode.el
+++ b/lisp/progmodes/elixir-ts-mode.el
@@ -360,13 +360,19 @@
(defvar elixir-ts--font-lock-settings
(treesit-font-lock-rules
:language 'elixir
- :feature 'elixir-function-name
+ :feature 'elixir-definition
`((call target: (identifier) @target-identifier
+ (arguments
+ (call target: (identifier) @font-lock-function-name-face
+ (arguments)))
+ (:match ,elixir-ts--definition-keywords-re @target-identifier))
+ (call target: (identifier) @target-identifier
(arguments (identifier) @font-lock-function-name-face)
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(call target: (identifier) @target-identifier
(arguments
- (call target: (identifier) @font-lock-function-name-face))
+ (call target: (identifier) @font-lock-function-name-face
+ (arguments ((identifier)) @font-lock-variable-name-face)))
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(call target: (identifier) @target-identifier
(arguments
@@ -379,13 +385,15 @@
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(call target: (identifier) @target-identifier
(arguments
- (call target: (identifier) @font-lock-function-name-face))
+ (call target: (identifier) @font-lock-function-name-face
+ (arguments ((identifier)) @font-lock-variable-name-face)))
(do_block)
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(call target: (identifier) @target-identifier
(arguments
(binary_operator
- left: (call target: (identifier) @font-lock-function-name-face)))
+ left: (call target: (identifier) @font-lock-function-name-face
+ (arguments ((identifier))
@font-lock-variable-name-face))))
(do_block)
(:match ,elixir-ts--definition-keywords-re @target-identifier))
(unary_operator
@@ -521,8 +529,8 @@
operator: "/" right: (integer)))
(call
target: (dot right: (identifier) @font-lock-function-call-face))
- (unary_operator operator: "&" @font-lock-variable-name-face
- operand: (integer) @font-lock-variable-name-face)
+ (unary_operator operator: "&" @font-lock-variable-use-face
+ operand: (integer) @font-lock-variable-use-face)
(unary_operator operator: "&" @font-lock-operator-face
operand: (list)))
@@ -537,16 +545,18 @@
:language 'elixir
:feature 'elixir-variable
- '((binary_operator left: (identifier) @font-lock-variable-name-face)
- (binary_operator right: (identifier) @font-lock-variable-name-face)
- (arguments ( (identifier) @font-lock-variable-name-face))
- (tuple (identifier) @font-lock-variable-name-face)
- (list (identifier) @font-lock-variable-name-face)
- (pair value: (identifier) @font-lock-variable-name-face)
- (body (identifier) @font-lock-variable-name-face)
- (unary_operator operand: (identifier) @font-lock-variable-name-face)
- (interpolation (identifier) @font-lock-variable-name-face)
- (do_block (identifier) @font-lock-variable-name-face))
+ '((binary_operator left: (identifier) @font-lock-variable-use-face)
+ (binary_operator right: (identifier) @font-lock-variable-use-face)
+ (arguments ( (identifier) @font-lock-variable-use-face))
+ (tuple (identifier) @font-lock-variable-use-face)
+ (list (identifier) @font-lock-variable-use-face)
+ (pair value: (identifier) @font-lock-variable-use-face)
+ (body (identifier) @font-lock-variable-use-face)
+ (unary_operator operand: (identifier) @font-lock-variable-use-face)
+ (interpolation (identifier) @font-lock-variable-use-face)
+ (do_block (identifier) @font-lock-variable-use-face)
+ (access_call target: (identifier) @font-lock-variable-use-face)
+ (access_call "[" key: (identifier) @font-lock-variable-use-face "]"))
:language 'elixir
:feature 'elixir-builtin
@@ -697,11 +707,10 @@ Return nil if NODE is not a defun node or doesn't have a
name."
;; Font-lock.
(setq-local treesit-font-lock-settings elixir-ts--font-lock-settings)
(setq-local treesit-font-lock-feature-list
- '(( elixir-comment elixir-doc elixir-function-name)
+ '(( elixir-comment elixir-doc elixir-definition)
( elixir-string elixir-keyword elixir-data-type)
- ( elixir-sigil elixir-variable elixir-builtin
- elixir-string-escape)
- ( elixir-function-call elixir-operator elixir-number )))
+ ( elixir-sigil elixir-builtin elixir-string-escape)
+ ( elixir-function-call elixir-variable elixir-operator
elixir-number )))
;; Imenu.
@@ -734,13 +743,12 @@ Return nil if NODE is not a defun node or doesn't have a
name."
heex-ts--indent-rules))
(setq-local treesit-font-lock-feature-list
- '(( elixir-comment elixir-doc elixir-function-name
+ '(( elixir-comment elixir-doc elixir-definition
heex-comment heex-keyword heex-doctype )
( elixir-string elixir-keyword elixir-data-type
heex-component heex-tag heex-attribute heex-string )
- ( elixir-sigil elixir-variable elixir-builtin
- elixir-string-escape)
- ( elixir-function-call elixir-operator elixir-number ))))
+ ( elixir-sigil elixir-builtin elixir-string-escape)
+ ( elixir-function-call elixir-variable elixir-operator
elixir-number ))))
(treesit-major-mode-setup)
(setq-local syntax-propertize-function #'elixir-ts--syntax-propertize)))
diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el
index b9bd772ddfc..476037eb8bd 100644
--- a/lisp/progmodes/etags.el
+++ b/lisp/progmodes/etags.el
@@ -1488,7 +1488,7 @@ hits the start of file."
(setq symbs (symbol-value symbs))
(insert (format-message "symbol `%s' has no value\n" symbs))
(setq symbs nil)))
- (if (vectorp symbs)
+ (if (obarrayp symbs)
(mapatoms ins-symb symbs)
(dolist (sy symbs)
(funcall ins-symb (car sy))))
@@ -2183,7 +2183,7 @@ file name, add `tag-partial-file-name-match-p' to the
list value.")
(setq symbs (symbol-value symbs))
(warn "symbol `%s' has no value" symbs)
(setq symbs nil))
- (if (vectorp symbs)
+ (if (obarrayp symbs)
(mapatoms add-xref symbs)
(dolist (sy symbs)
(funcall add-xref (car sy))))
diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el
index 5974f076556..db00cc59c0e 100644
--- a/lisp/progmodes/flymake.el
+++ b/lisp/progmodes/flymake.el
@@ -1569,13 +1569,19 @@ correctly.")
,flymake-mode-line-lighter
mouse-face mode-line-highlight
help-echo
- ,(lambda (&rest _)
- (concat
- (format "%s known backends\n" (hash-table-count flymake--state))
- (format "%s running\n" (length (flymake-running-backends)))
- (format "%s disabled\n" (length (flymake-disabled-backends)))
- "mouse-1: Display minor mode menu\n"
- "mouse-2: Show help for minor mode"))
+ ,(lambda (w &rest _)
+ (with-current-buffer (window-buffer w)
+ ;; Mouse can activate tool-tip without window being active.
+ ;; `flymake--state' is buffer local and is null when line
+ ;; lighter appears in *Help* `describe-mode'.
+ (concat
+ (unless (null flymake--state)
+ (concat
+ (format "%s known backends\n" (hash-table-count flymake--state))
+ (format "%s running\n" (length (flymake-running-backends)))
+ (format "%s disabled\n" (length (flymake-disabled-backends)))))
+ "mouse-1: Display minor mode menu\n"
+ "mouse-2: Show help for minor mode")))
keymap
,(let ((map (make-sparse-keymap)))
(define-key map [mode-line down-mouse-1]
diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el
index be6357f4139..b7c85fe7f43 100644
--- a/lisp/progmodes/gud.el
+++ b/lisp/progmodes/gud.el
@@ -243,7 +243,7 @@ Check it when `gud-running' is t")
:visible (eq gud-minor-mode 'gdbmi)]
["Print Expression" gud-print
:enable (not gud-running)]
- ["Dump object-Derefenrece" gud-pstar
+ ["Dump object-Dereference" gud-pstar
:label (if (eq gud-minor-mode 'jdb)
"Dump object"
"Print Dereference")
diff --git a/lisp/progmodes/heex-ts-mode.el b/lisp/progmodes/heex-ts-mode.el
index 7b53a44deb2..22e8956661d 100644
--- a/lisp/progmodes/heex-ts-mode.el
+++ b/lisp/progmodes/heex-ts-mode.el
@@ -166,6 +166,16 @@ With ARG, do it many times. Negative ARG means move
backward."
("Slot" "\\`slot\\'" nil nil)
("Tag" "\\`tag\\'" nil nil)))
+ ;; Outline minor mode
+ ;; `heex-ts-mode' inherits from `html-mode' that sets
+ ;; regexp-based outline variables. So need to restore
+ ;; the default values of outline variables to be able
+ ;; to use `treesit-outline-predicate' derived
+ ;; from `treesit-simple-imenu-settings' above.
+ (kill-local-variable 'outline-heading-end-regexp)
+ (kill-local-variable 'outline-regexp)
+ (kill-local-variable 'outline-level)
+
(setq-local treesit-font-lock-settings heex-ts--font-lock-settings)
(setq-local treesit-simple-indent-rules heex-ts--indent-rules)
diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el
index 71f55379d96..98e567299a1 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/progmodes/hideif.el
@@ -390,7 +390,7 @@ If there is a marked region from START to END it only shows
the symbols within."
(defun hif-after-revert-function ()
(and hide-ifdef-mode hide-ifdef-hiding
(hide-ifdefs nil nil t)))
-(add-hook 'after-revert-hook 'hif-after-revert-function)
+(add-hook 'after-revert-hook #'hif-after-revert-function)
(defun hif-end-of-line ()
"Find the end-point of line concatenation."
@@ -474,7 +474,7 @@ Everything including these lines is made invisible."
(defun hif-eval (form)
"Evaluate hideif internal representation."
- (let ((val (eval form)))
+ (let ((val (eval form t)))
(if (stringp val)
(or (get-text-property 0 'hif-value val)
val)
@@ -542,7 +542,7 @@ that form should be displayed.")
(defconst hif-cpp-prefix "\\(^\\|\r\\)?[ \t]*#[ \t]*")
(defconst hif-ifxdef-regexp (concat hif-cpp-prefix "if\\(n\\)?def"))
(defconst hif-ifndef-regexp (concat hif-cpp-prefix "ifndef"))
-(defconst hif-ifx-regexp (concat hif-cpp-prefix "if\\((\\|\\(n?def\\)?[
\t]+\\)"))
+(defvar hif-ifx-regexp (concat hif-cpp-prefix "if\\((\\|\\(n?def\\)?[
\t]+\\)"))
(defconst hif-elif-regexp (concat hif-cpp-prefix "elif"))
(defconst hif-else-regexp (concat hif-cpp-prefix "else"))
(defconst hif-endif-regexp (concat hif-cpp-prefix "endif"))
@@ -679,7 +679,7 @@ that form should be displayed.")
("..." . hif-etc)
("defined" . hif-defined)))
-(defconst hif-valid-token-list (mapcar 'cdr hif-token-alist))
+(defconst hif-valid-token-list (mapcar #'cdr hif-token-alist))
(defconst hif-token-regexp
;; The ordering of regexp grouping is crucial to `hif-strtok'
@@ -690,7 +690,7 @@ that form should be displayed.")
;; decimal/octal:
"\\|\\(\\([+-]?[0-9']+\\(\\.[0-9']*\\)?\\)\\([eE][+-]?[0-9]+\\)?"
hif-numtype-suffix-regexp "?\\)"
- "\\|" (regexp-opt (mapcar 'car hif-token-alist) t)
+ "\\|" (regexp-opt (mapcar #'car hif-token-alist) t)
"\\|\\(\\w+\\)"))
;; C++11 Unicode string literals (L"" u8"" u"" U"" R"" LR"" u8R"" uR"")
@@ -867,7 +867,7 @@ Assuming we've just performed a `hif-token-regexp' lookup."
(t
(setq hif-simple-token-only nil)
- (intern-safe string)))))
+ (hif--intern-safe string)))))
(defun hif-backward-comment (&optional start end)
"If we're currently within a C(++) comment, skip them backwards."
@@ -1448,7 +1448,7 @@ This macro cannot be evaluated alone without parameters
input."
(t
(error "Invalid token to stringify"))))
-(defun intern-safe (str)
+(defun hif--intern-safe (str)
(if (stringp str)
(intern str)))
diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el
index 0f11103cf02..b5d91f46b17 100644
--- a/lisp/progmodes/idlw-shell.el
+++ b/lisp/progmodes/idlw-shell.el
@@ -96,8 +96,8 @@
(defcustom idlwave-shell-prompt-pattern "^\r? ?IDL> "
"Regexp to match IDL prompt at beginning of a line.
-For example, \"^\r?IDL> \" or \"^\r?WAVE> \".
-The \"^\r?\" is needed, to indicate the beginning of the line, with
+For example, \"^\\r?IDL> \" or \"^\\r?WAVE> \".
+The \"^\\r?\" is needed, to indicate the beginning of the line, with
optional return character (which IDL seems to output randomly).
This variable is used to initialize `comint-prompt-regexp' in the
process buffer."
diff --git a/lisp/progmodes/java-ts-mode.el b/lisp/progmodes/java-ts-mode.el
index 0b1ac49b99f..00d7d0d75a1 100644
--- a/lisp/progmodes/java-ts-mode.el
+++ b/lisp/progmodes/java-ts-mode.el
@@ -74,7 +74,12 @@
((parent-is "program") column-0 0)
((match "}" "element_value_array_initializer")
parent-bol 0)
- ((node-is "}") column-0 c-ts-common-statement-offset)
+ ((node-is
+ ,(format "\\`%s\\'"
+ (regexp-opt '("constructor_body" "class_body" "interface_body"
+ "block" "switch_block" "array_initializer"))))
+ parent-bol 0)
+ ((node-is "}") standalone-parent 0)
((node-is ")") parent-bol 0)
((node-is "else") parent-bol 0)
((node-is "]") parent-bol 0)
@@ -86,10 +91,10 @@
((parent-is "array_initializer") parent-bol java-ts-mode-indent-offset)
((parent-is "annotation_type_body") column-0 c-ts-common-statement-offset)
((parent-is "interface_body") column-0 c-ts-common-statement-offset)
- ((parent-is "constructor_body") column-0 c-ts-common-statement-offset)
+ ((parent-is "constructor_body") standalone-parent
java-ts-mode-indent-offset)
((parent-is "enum_body_declarations") parent-bol 0)
((parent-is "enum_body") column-0 c-ts-common-statement-offset)
- ((parent-is "switch_block") column-0 c-ts-common-statement-offset)
+ ((parent-is "switch_block") standalone-parent java-ts-mode-indent-offset)
((parent-is "record_declaration_body") column-0
c-ts-common-statement-offset)
((query "(method_declaration (block _ @indent))") parent-bol
java-ts-mode-indent-offset)
((query "(method_declaration (block (_) @indent))") parent-bol
java-ts-mode-indent-offset)
@@ -125,7 +130,7 @@
((parent-is "case_statement") parent-bol java-ts-mode-indent-offset)
((parent-is "labeled_statement") parent-bol java-ts-mode-indent-offset)
((parent-is "do_statement") parent-bol java-ts-mode-indent-offset)
- ((parent-is "block") column-0 c-ts-common-statement-offset)))
+ ((parent-is "block") standalone-parent java-ts-mode-indent-offset)))
"Tree-sitter indent rules.")
(defvar java-ts-mode--keywords
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el
index 947d91c9b1a..ebc098e6a75 100644
--- a/lisp/progmodes/js.el
+++ b/lisp/progmodes/js.el
@@ -3418,6 +3418,26 @@ This function is intended for use in
`after-change-functions'."
;;; Tree sitter integration
+(defun js--treesit-font-lock-compatibility-definition-feature ()
+ "Font lock helper, to handle different releases of tree-sitter-javascript.
+Check if a node type is available, then return the right font lock rules
+for \"definition\" feature."
+ (condition-case nil
+ (progn (treesit-query-capture 'javascript '((function_expression) @cap))
+ ;; Starting from version 0.20.2 of the grammar.
+ '((function_expression
+ name: (identifier) @font-lock-function-name-face)
+ (variable_declarator
+ name: (identifier) @font-lock-function-name-face
+ value: [(function_expression) (arrow_function)])))
+ (error
+ ;; An older version of the grammar.
+ '((function
+ name: (identifier) @font-lock-function-name-face)
+ (variable_declarator
+ name: (identifier) @font-lock-function-name-face
+ value: [(function) (arrow_function)])))))
+
(defun js-jsx--treesit-indent-compatibility-bb1f97b ()
"Indent rules helper, to handle different releases of tree-sitter-javascript.
Check if a node type is available, then return the right indent rules."
@@ -3529,8 +3549,7 @@ Check if a node type is available, then return the right
indent rules."
:language 'javascript
:feature 'definition
- '((function
- name: (identifier) @font-lock-function-name-face)
+ `(,@(js--treesit-font-lock-compatibility-definition-feature)
(class_declaration
name: (identifier) @font-lock-type-face)
@@ -3549,10 +3568,6 @@ Check if a node type is available, then return the right
indent rules."
(variable_declarator
name: (identifier) @font-lock-variable-name-face)
- (variable_declarator
- name: (identifier) @font-lock-function-name-face
- value: [(function) (arrow_function)])
-
(variable_declarator
name: [(array_pattern (identifier) @font-lock-variable-name-face)
(object_pattern
diff --git a/lisp/progmodes/lua-ts-mode.el b/lisp/progmodes/lua-ts-mode.el
index 05a3ff6d7c6..8bd3db2b75f 100644
--- a/lisp/progmodes/lua-ts-mode.el
+++ b/lisp/progmodes/lua-ts-mode.el
@@ -26,8 +26,8 @@
;; This package provides `lua-ts-mode' which is a major mode for Lua
;; files that uses Tree Sitter to parse the language.
;;
-;; This package is compatible with and tested against the grammar
-;; for Lua found at https://github.com/MunifTanjim/tree-sitter-lua
+;; This package is compatible with and tested against the grammar for
+;; Lua found at https://github.com/tree-sitter-grammars/tree-sitter-lua
;;; Code:
@@ -317,6 +317,8 @@ values of OVERRIDE."
(node-is ")")
(node-is "}"))
standalone-parent 0)
+ ((match null "table_constructor")
+ standalone-parent lua-ts-indent-offset)
((or (and (parent-is "arguments") lua-ts--first-child-matcher)
(and (parent-is "parameters") lua-ts--first-child-matcher)
(and (parent-is "table_constructor") lua-ts--first-child-matcher))
@@ -774,7 +776,7 @@ Calls REPORT-FN directly."
"vararg_expression"))))
(text "comment"))))
- ;; Imenu.
+ ;; Imenu/Outline.
(setq-local treesit-simple-imenu-settings
`(("Requires"
"\\`function_call\\'"
@@ -789,16 +791,6 @@ Calls REPORT-FN directly."
;; Which-function.
(setq-local which-func-functions (treesit-defun-at-point))
- ;; Outline.
- (setq-local outline-regexp
- (rx (seq (0+ space)
- (or (seq "--[[" (0+ space) eol)
- (seq symbol-start
- (or "do" "for" "if" "repeat" "while"
- (seq (? (seq "local" (1+ space)))
- "function"))
- symbol-end)))))
-
;; Align.
(setq-local align-indent-before-aligning t)
diff --git a/lisp/progmodes/modula2.el b/lisp/progmodes/modula2.el
index 09cb848fd52..2bb31988290 100644
--- a/lisp/progmodes/modula2.el
+++ b/lisp/progmodes/modula2.el
@@ -325,20 +325,20 @@ followed by the first character of the construct.
;;
;; Module definitions.
("\\<\\(INTERFACE\\|MODULE\\|PROCEDURE\\)\\>[ \t]*\\(\\sw+\\)?"
- (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
+ (1 'font-lock-keyword-face) (2 'font-lock-function-name-face nil t))
;;
;; Import directives.
("\\<\\(EXPORTS\\|FROM\\|IMPORT\\)\\>"
- (1 font-lock-keyword-face)
+ (1 'font-lock-keyword-face)
(font-lock-match-c-style-declaration-item-and-skip-to-next
nil (goto-char (match-end 0))
- (1 font-lock-constant-face)))
+ (1 'font-lock-constant-face)))
;;
;; Pragmas as warnings.
;; Spencer Allain <sallain@teknowledge.com> says do them as comments...
;; ("<\\*.*\\*>" . font-lock-warning-face)
;; ... but instead we fontify the first word.
- ("<\\*[ \t]*\\(\\sw+\\)" 1 font-lock-warning-face prepend)
+ ("<\\*[ \t]*\\(\\sw+\\)" 1 'font-lock-warning-face prepend)
)
"Subdued level highlighting for Modula-3 modes.")
@@ -366,26 +366,29 @@ followed by the first character of the construct.
"LOOPHOLE" "MAX" "MIN" "NARROW" "NEW" "NUMBER" "ORD"
"ROUND" "SUBARRAY" "TRUNC" "TYPECODE" "VAL")))
)
- (list
- ;;
- ;; Keywords except those fontified elsewhere.
- (concat "\\<\\(" m3-keywords "\\)\\>")
- ;;
- ;; Builtins.
- (cons (concat "\\<\\(" m3-builtins "\\)\\>") 'font-lock-builtin-face)
- ;;
- ;; Type names.
- (cons (concat "\\<\\(" m3-types "\\)\\>") 'font-lock-type-face)
- ;;
- ;; Fontify tokens as function names.
- '("\\<\\(END\\|EXCEPTION\\|RAISES?\\)\\>[ \t{]*"
- (1 font-lock-keyword-face)
+ `(
+ ;;
+ ;; Keywords except those fontified elsewhere.
+ ,(concat "\\<\\(" m3-keywords "\\)\\>")
+ ;;
+ ;; Builtins.
+ (,(concat "\\<\\(" m3-builtins "\\)\\>")
+ (0 'font-lock-builtin-face))
+ ;;
+ ;; Type names.
+ (,(concat "\\<\\(" m3-types "\\)\\>")
+ (0 'font-lock-type-face))
+ ;;
+ ;; Fontify tokens as function names.
+ ("\\<\\(END\\|EXCEPTION\\|RAISES?\\)\\>[ \t{]*"
+ (1 'font-lock-keyword-face)
(font-lock-match-c-style-declaration-item-and-skip-to-next
nil (goto-char (match-end 0))
- (1 font-lock-function-name-face)))
- ;;
- ;; Fontify constants as references.
- '("\\<\\(FALSE\\|NIL\\|NULL\\|TRUE\\)\\>" . font-lock-constant-face)
+ (1 'font-lock-function-name-face)))
+ ;;
+ ;; Fontify constants as references.
+ ("\\<\\(FALSE\\|NIL\\|NULL\\|TRUE\\)\\>"
+ (0 'font-lock-constant-face))
))))
"Gaudy level highlighting for Modula-3 modes.")
diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el
index 5e8263cb646..a80e12b8129 100644
--- a/lisp/progmodes/opascal.el
+++ b/lisp/progmodes/opascal.el
@@ -281,7 +281,7 @@ nested routine.")
(eval-when-compile
(pcase-defmacro opascal--in (set)
- `(pred (pcase--flip memq ,set))))
+ `(pred (memq _ ,set))))
(defun opascal-string-of (start end)
;; Returns the buffer string from start to end.
diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el
index da782ad5537..9622b1b6768 100644
--- a/lisp/progmodes/project.el
+++ b/lisp/progmodes/project.el
@@ -992,9 +992,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'."
;;;###autoload
(defun project-or-external-find-regexp (regexp)
- "Find all matches for REGEXP in the project roots or external roots.
-With \\[universal-argument] prefix, you can specify the file name
-pattern to search for."
+ "Find all matches for REGEXP in the project roots or external roots."
(interactive (list (project--read-regexp)))
(require 'xref)
(let* ((pr (project-current t))
@@ -1515,7 +1513,8 @@ ARG, show only buffers that are visiting files."
(lambda (buffer)
(let ((name (buffer-name buffer))
(file (buffer-file-name buffer)))
- (and (or (not (string= (substring name 0 1) " "))
+ (and (or Buffer-menu-show-internal
+ (not (string= (substring name 0 1) " "))
file)
(not (eq buffer (current-buffer)))
(or file (not Buffer-menu-files-only)))))
@@ -1525,6 +1524,7 @@ ARG, show only buffers that are visiting files."
(let ((buf (list-buffers-noselect
arg (with-current-buffer
(get-buffer-create "*Buffer List*")
+ (setq-local Buffer-menu-show-internal nil)
(let ((Buffer-menu-files-only arg))
(funcall buffer-list-function))))))
(with-current-buffer buf
@@ -1866,12 +1866,12 @@ 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."
+`overriding-terminal-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))
+ (command (let ((overriding-terminal-local-map overriding-map))
(key-binding (read-key-sequence
(format prompt-format (project-root pr)))
t)))
diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el
index 9d840efb9da..bedc61408ef 100644
--- a/lisp/progmodes/python.el
+++ b/lisp/progmodes/python.el
@@ -5,7 +5,7 @@
;; Author: Fabián E. Gallina <fgallina@gnu.org>
;; URL: https://github.com/fgallina/python.el
;; Version: 0.28
-;; Package-Requires: ((emacs "24.4") (compat "28.1.2.1") (seq "2.23"))
+;; Package-Requires: ((emacs "24.4") (compat "29.1.1.0") (seq "2.23"))
;; Maintainer: emacs-devel@gnu.org
;; Created: Jul 2010
;; Keywords: languages
@@ -128,9 +128,9 @@
;; receiving escape sequences (with some limitations, i.e. completion
;; in blocks does not work). The code executed for the "fallback"
;; completion can be found in `python-shell-completion-setup-code' and
-;; `python-shell-completion-string-code' variables. Their default
-;; values enable completion for both CPython and IPython, and probably
-;; any readline based shell (it's known to work with PyPy). If your
+;; `python-shell-completion-get-completions'. Their default values
+;; enable completion for both CPython and IPython, and probably any
+;; readline based shell (it's known to work with PyPy). If your
;; Python installation lacks readline (like CPython for Windows),
;; installing pyreadline (URL `https://ipython.org/pyreadline.html')
;; should suffice. To troubleshoot why you are not getting any
@@ -141,6 +141,12 @@
;; If you see an error, then you need to either install pyreadline or
;; setup custom code that avoids that dependency.
+;; By default, the "native" completion uses the built-in rlcompleter.
+;; To use other readline completer (e.g. Jedi) or a custom one, you just
+;; need to set it in the PYTHONSTARTUP file. You can set an
+;; Emacs-specific completer by testing the environment variable
+;; INSIDE_EMACS.
+
;; Shell virtualenv support: The shell also contains support for
;; virtualenvs and other special environment modifications thanks to
;; `python-shell-process-environment' and `python-shell-exec-path'.
@@ -267,7 +273,7 @@
(eval-when-compile (require 'subr-x)) ;For `string-empty-p' and
`string-join'.
(require 'treesit)
(require 'pcase)
-(require 'compat nil 'noerror)
+(require 'compat)
(require 'project nil 'noerror)
(require 'seq)
@@ -3515,6 +3521,16 @@ eventually provide a shell."
:version "25.1"
:type 'hook)
+(defconst python-shell-setup-code
+ "\
+try:
+ import tty
+except ImportError:
+ pass
+else:
+ tty.setraw(0)"
+ "Code used to setup the inferior Python processes.")
+
(defconst python-shell-eval-setup-code
"\
def __PYTHON_EL_eval(source, filename):
@@ -3580,6 +3596,7 @@ The coding cookie regexp is specified in PEP 263.")
(format "exec(%s)\n" (python-shell--encode-string
string))))))
;; Bootstrap: the normal definition of `python-shell-send-string'
;; depends on the Python code sent here.
+ (python-shell-send-string-no-output python-shell-setup-code)
(python-shell-send-string-no-output python-shell-eval-setup-code)
(python-shell-send-string-no-output
python-shell-eval-file-setup-code))
(with-current-buffer (current-buffer)
@@ -3604,7 +3621,6 @@ interpreter is run. Variables
`python-shell-prompt-block-regexp',
`python-shell-font-lock-enable',
`python-shell-completion-setup-code',
-`python-shell-completion-string-code',
`python-eldoc-setup-code',
`python-ffap-setup-code' can
customize this mode for different Python interpreters.
@@ -4244,8 +4260,9 @@ def __PYTHON_EL_get_completions(text):
completions = []
completer = None
+ import json
try:
- import readline
+ import readline, re
try:
import __builtin__
@@ -4256,16 +4273,29 @@ def __PYTHON_EL_get_completions(text):
is_ipython = ('__IPYTHON__' in builtins or
'__IPYTHON__active' in builtins)
- splits = text.split()
- is_module = splits and splits[0] in ('from', 'import')
-
- if is_ipython and is_module:
- from IPython.core.completerlib import module_completion
- completions = module_completion(text.strip())
- elif is_ipython and '__IP' in builtins:
- completions = __IP.complete(text)
- elif is_ipython and 'get_ipython' in builtins:
- completions = get_ipython().Completer.all_completions(text)
+
+ if is_ipython and 'get_ipython' in builtins:
+ def filter_c(prefix, c):
+ if re.match('_+(i?[0-9]+)?$', c):
+ return False
+ elif c[0] == '%' and not re.match('[%a-zA-Z]+$', prefix):
+ return False
+ return True
+
+ import IPython
+ try:
+ if IPython.version_info[0] >= 6:
+ from IPython.core.completer import provisionalcompleter
+ with provisionalcompleter():
+ completions = [
+ [c.text, c.start, c.end, c.type or '?',
c.signature or '']
+ for c in
get_ipython().Completer.completions(text, len(text))
+ if filter_c(text, c.text)]
+ else:
+ part, matches =
get_ipython().Completer.complete(line_buffer=text)
+ completions = [text + m[len(part):] for m in matches if
filter_c(text, m)]
+ except:
+ pass
else:
# Try to reuse current completer.
completer = readline.get_completer()
@@ -4288,7 +4318,7 @@ def __PYTHON_EL_get_completions(text):
finally:
if getattr(completer, 'PYTHON_EL_WRAPPED', False):
completer.print_mode = True
- return completions"
+ return json.dumps(completions)"
"Code used to setup completion in inferior Python processes."
:type 'string)
@@ -4329,6 +4359,10 @@ When a match is found, native completion is disabled."
:version "25.1"
:type 'float)
+(defvar python-shell-readline-completer-delims nil
+ "Word delimiters used by the readline completer.
+It is automatically set by Python shell.")
+
(defvar python-shell-completion-native-redirect-buffer
" *Python completions redirect*"
"Buffer to be used to redirect output of readline commands.")
@@ -4467,6 +4501,10 @@ def __PYTHON_EL_native_completion_setup():
__PYTHON_EL_native_completion_setup()" process)))
(when (string-match-p "python\\.el: native completion setup loaded"
output)
+ (setq-local python-shell-readline-completer-delims
+ (string-trim-right
+ (python-shell-send-string-no-output
+ "import readline;
print(readline.get_completer_delims())")))
(python-shell-completion-native-try))))
(defun python-shell-completion-native-turn-off (&optional msg)
@@ -4498,18 +4536,11 @@ With argument MSG show activation/deactivation message."
((python-shell-completion-native-setup)
(when msg
(message "Shell native completion is enabled.")))
- (t (lwarn
- '(python python-shell-completion-native-turn-on-maybe)
- :warning
- (concat
- "Your `python-shell-interpreter' doesn't seem to "
- "support readline, yet `python-shell-completion-native-enable' "
- (format "was t and %S is not part of the "
- (file-name-nondirectory python-shell-interpreter))
- "`python-shell-completion-native-disabled-interpreters' "
- "list. Native completions have been disabled locally. "
- "Consider installing the python package \"readline\". "))
- (python-shell-completion-native-turn-off msg))))))
+ (t
+ (when msg
+ (message (concat "Python does not use GNU readline;"
+ " no completion in multi-line commands.")))
+ (python-shell-completion-native-turn-off nil))))))
(defun python-shell-completion-native-turn-on-maybe-with-msg ()
"Like `python-shell-completion-native-turn-on-maybe' but force messages."
@@ -4534,6 +4565,8 @@ With argument MSG show activation/deactivation message."
(let* ((original-filter-fn (process-filter process))
(redirect-buffer (get-buffer-create
python-shell-completion-native-redirect-buffer))
+ (sep (if (string= python-shell-readline-completer-delims "")
+ "[\n\r]+" "[ \f\t\n\r\v()]+"))
(trigger "\t")
(new-input (concat input trigger))
(input-length
@@ -4576,28 +4609,80 @@ With argument MSG show activation/deactivation message."
process python-shell-completion-native-output-timeout
comint-redirect-finished-regexp)
(re-search-backward "0__dummy_completion__" nil t)
- (cl-remove-duplicates
- (split-string
- (buffer-substring-no-properties
- (line-beginning-position) (point-min))
- "[ \f\t\n\r\v()]+" t)
- :test #'string=))))
+ (let ((str (buffer-substring-no-properties
+ (line-beginning-position) (point-min))))
+ ;; The readline completer is allowed to return a list
+ ;; of (text start end type signature) as a JSON
+ ;; string. See the return value for IPython in
+ ;; `python-shell-completion-setup-code'.
+ (if (string= "[" (substring str 0 1))
+ (condition-case nil
+ (python--parse-json-array str)
+ (t (cl-remove-duplicates (split-string str sep t)
+ :test #'string=)))
+ (cl-remove-duplicates (split-string str sep t)
+ :test #'string=))))))
(set-process-filter process original-filter-fn)))))
(defun python-shell-completion-get-completions (process input)
"Get completions of INPUT using PROCESS."
(with-current-buffer (process-buffer process)
- (let ((completions
- (python-util-strip-string
- (python-shell-send-string-no-output
- (format
- "%s\nprint(';'.join(__PYTHON_EL_get_completions(%s)))"
+ (python--parse-json-array
+ (python-shell-send-string-no-output
+ (format "%s\nprint(__PYTHON_EL_get_completions(%s))"
python-shell-completion-setup-code
(python-shell--encode-string input))
- process))))
- (when (> (length completions) 2)
- (split-string completions
- "^'\\|^\"\\|;\\|'$\\|\"$" t)))))
+ process))))
+
+(defun python-shell--get-multiline-input ()
+ "Return lines at a multi-line input in Python shell."
+ (save-excursion
+ (let ((p (point)) lines)
+ (when (progn
+ (beginning-of-line)
+ (looking-back python-shell-prompt-block-regexp (pos-bol)))
+ (push (buffer-substring-no-properties (point) p) lines)
+ (while (progn (comint-previous-prompt 1)
+ (looking-back python-shell-prompt-block-regexp
(pos-bol)))
+ (push (buffer-substring-no-properties (point) (pos-eol)) lines))
+ (push (buffer-substring-no-properties (point) (pos-eol)) lines))
+ lines)))
+
+(defun python-shell--extra-completion-context ()
+ "Get extra completion context of current input in Python shell."
+ (let ((lines (python-shell--get-multiline-input))
+ (python-indent-guess-indent-offset nil))
+ (when (not (zerop (length lines)))
+ (with-temp-buffer
+ (delay-mode-hooks
+ (insert (string-join lines "\n"))
+ (python-mode)
+ (python-shell-completion-extra-context))))))
+
+(defun python-shell-completion-extra-context (&optional pos)
+ "Get extra completion context at position POS in Python buffer.
+If optional argument POS is nil, use current position.
+
+Readline completers could use current line as the completion
+context, which may be insufficient. In this function, extra
+context (e.g. multi-line function call) is found and reformatted
+as one line, which is required by native completion."
+ (let (bound p)
+ (save-excursion
+ (and pos (goto-char pos))
+ (setq bound (pos-bol))
+ (python-nav-up-list -1)
+ (when (and (< (point) bound)
+ (or
+ (looking-back
+ (python-rx (group (+ (or "." symbol-name)))) (pos-bol) t)
+ (progn
+ (forward-line 0)
+ (looking-at "^[ \t]*\\(from \\)"))))
+ (setq p (match-beginning 1))))
+ (when p
+ (replace-regexp-in-string
+ "\n[ \t]*" "" (buffer-substring-no-properties p (1- bound))))))
(defvar-local python-shell--capf-cache nil
"Variable to store cached completions and invalidation keys.")
@@ -4612,21 +4697,26 @@ using that one instead of current buffer's process."
;; Working on a shell buffer: use prompt end.
(cdr (python-util-comint-last-prompt))
(line-beginning-position)))
- (import-statement
- (when (string-match-p
- (rx (* space) word-start (or "from" "import") word-end space)
- (buffer-substring-no-properties line-start (point)))
- (buffer-substring-no-properties line-start (point))))
+ (no-delims
+ (and (not (if is-shell-buffer
+ (eq 'font-lock-comment-face
+ (get-text-property (1- (point)) 'face))
+ (python-syntax-context 'comment)))
+ (with-current-buffer (process-buffer process)
+ (if python-shell-completion-native-enable
+ (string= python-shell-readline-completer-delims "")
+ (string-match-p "ipython[23]?\\'"
python-shell-interpreter)))))
(start
(if (< (point) line-start)
(point)
(save-excursion
- (if (not (re-search-backward
- (python-rx
- (or whitespace open-paren close-paren
- string-delimiter simple-operator))
- line-start
- t 1))
+ (if (or no-delims
+ (not (re-search-backward
+ (python-rx
+ (or whitespace open-paren close-paren
+ string-delimiter simple-operator))
+ line-start
+ t 1)))
line-start
(forward-char (length (match-string-no-properties 0)))
(point)))))
@@ -4666,18 +4756,56 @@ using that one instead of current buffer's process."
(t #'python-shell-completion-native-get-completions))))
(prev-prompt (car python-shell--capf-cache))
(re (or (cadr python-shell--capf-cache) regexp-unmatchable))
- (prefix (buffer-substring-no-properties start end)))
+ (prefix (buffer-substring-no-properties start end))
+ (prefix-offset 0)
+ (extra-context (when no-delims
+ (if is-shell-buffer
+ (python-shell--extra-completion-context)
+ (python-shell-completion-extra-context))))
+ (extra-offset (length extra-context)))
+ (unless (zerop extra-offset)
+ (setq prefix (concat extra-context prefix)))
;; To invalidate the cache, we check if the prompt position or the
;; completion prefix changed.
(unless (and (equal prev-prompt (car prompt-boundaries))
- (string-match re prefix))
+ (string-match re prefix)
+ (setq prefix-offset (- (length prefix) (match-end 1))))
(setq python-shell--capf-cache
`(,(car prompt-boundaries)
,(if (string-empty-p prefix)
regexp-unmatchable
- (concat "\\`" (regexp-quote prefix)
"\\(?:\\sw\\|\\s_\\)*\\'"))
- ,@(funcall completion-fn process (or import-statement prefix)))))
- (list start end (cddr python-shell--capf-cache))))
+ (concat "\\`\\(" (regexp-quote prefix)
"\\)\\(?:\\sw\\|\\s_\\)*\\'"))
+ ,@(funcall completion-fn process prefix))))
+ (let ((cands (cddr python-shell--capf-cache)))
+ (cond
+ ((stringp (car cands))
+ (if no-delims
+ ;; Reduce completion candidates due to long prefix.
+ (if-let ((Lp (length prefix))
+ ((string-match "\\(\\sw\\|\\s_\\)+\\'" prefix))
+ (L (match-beginning 0)))
+ ;; If extra-offset is not zero:
+ ;; start end
+ ;; o------------------o---------o-------o
+ ;; |<- extra-offset ->|
+ ;; |<----------- L ------------>|
+ ;; new-start
+ (list (+ start L (- extra-offset)) end
+ (mapcar (lambda (s) (substring s L)) cands))
+ (list end end (mapcar (lambda (s) (substring s Lp)) cands)))
+ (list start end cands)))
+ ;; python-shell-completion(-native)-get-completions may produce a
+ ;; list of (text start end type signature) for completion.
+ ((consp (car cands))
+ (list (+ start (nth 1 (car cands)) (- extra-offset))
+ ;; Candidates may be cached, so the end position should
+ ;; be adjusted according to current completion prefix.
+ (+ start (nth 2 (car cands)) (- extra-offset) prefix-offset)
+ cands
+ :annotation-function
+ (lambda (c) (concat " " (nth 3 (assoc c cands))))
+ :company-docsig
+ (lambda (c) (nth 4 (assoc c cands)))))))))
(define-obsolete-function-alias
'python-shell-completion-complete-at-point
diff --git a/lisp/progmodes/ruby-ts-mode.el b/lisp/progmodes/ruby-ts-mode.el
index 598eaa461ff..426ae248cac 100644
--- a/lisp/progmodes/ruby-ts-mode.el
+++ b/lisp/progmodes/ruby-ts-mode.el
@@ -1133,6 +1133,7 @@ leading double colon is not added."
"singleton_class"
"module"
"method"
+ "singleton_method"
"array"
"hash"
"parenthesized_statements"
@@ -1178,6 +1179,19 @@ leading double colon is not added."
;; Imenu.
(setq-local imenu-create-index-function #'ruby-ts--imenu)
+ ;; Outline minor mode.
+ (setq-local treesit-outline-predicate
+ (rx bos (or "singleton_method"
+ "method"
+ "alias"
+ "class"
+ "module")
+ eos))
+ ;; Restore default values of outline variables
+ ;; to use `treesit-outline-predicate'.
+ (kill-local-variable 'outline-regexp)
+ (kill-local-variable 'outline-level)
+
(setq-local treesit-simple-indent-rules (ruby-ts--indent-rules))
;; Font-lock.
diff --git a/lisp/progmodes/typescript-ts-mode.el
b/lisp/progmodes/typescript-ts-mode.el
index e9c6afff440..9ee9432e4ee 100644
--- a/lisp/progmodes/typescript-ts-mode.el
+++ b/lisp/progmodes/typescript-ts-mode.el
@@ -199,183 +199,197 @@ Argument LANGUAGE is either `typescript' or `tsx'."
[(nested_identifier (identifier)) (identifier)]
@typescript-ts-jsx-tag-face)))))
+(defun tsx-ts-mode--font-lock-compatibility-function-expression (language)
+ "Handle tree-sitter grammar breaking change for `function' expression.
+
+LANGUAGE can be `typescript' or `tsx'. Starting from version 0.20.4 of the
+typescript/tsx grammar, `function' becomes `function_expression'."
+ (condition-case nil
+ (progn (treesit-query-capture language '((function_expression) @cap))
+ ;; New version of the grammar
+ 'function_expression)
+ (treesit-query-error
+ ;; Old version of the grammar
+ 'function)))
+
(defun typescript-ts-mode--font-lock-settings (language)
"Tree-sitter font-lock settings.
Argument LANGUAGE is either `typescript' or `tsx'."
- (treesit-font-lock-rules
- :language language
- :feature 'comment
- `([(comment) (hash_bang_line)] @font-lock-comment-face)
-
- :language language
- :feature 'constant
- `(((identifier) @font-lock-constant-face
- (:match "\\`[A-Z_][0-9A-Z_]*\\'" @font-lock-constant-face))
- [(true) (false) (null)] @font-lock-constant-face)
-
- :language language
- :feature 'keyword
- `([,@typescript-ts-mode--keywords] @font-lock-keyword-face
- [(this) (super)] @font-lock-keyword-face)
-
- :language language
- :feature 'string
- `((regex pattern: (regex_pattern)) @font-lock-regexp-face
- (string) @font-lock-string-face
- (template_string) @js--fontify-template-string
- (template_substitution ["${" "}"] @font-lock-misc-punctuation-face))
-
- :language language
- :override t ;; for functions assigned to variables
- :feature 'declaration
- `((function
- name: (identifier) @font-lock-function-name-face)
- (function_declaration
- name: (identifier) @font-lock-function-name-face)
- (function_signature
- name: (identifier) @font-lock-function-name-face)
-
- (method_definition
- name: (property_identifier) @font-lock-function-name-face)
- (method_signature
- name: (property_identifier) @font-lock-function-name-face)
- (required_parameter (identifier) @font-lock-variable-name-face)
- (optional_parameter (identifier) @font-lock-variable-name-face)
-
- (variable_declarator
- name: (identifier) @font-lock-function-name-face
- value: [(function) (arrow_function)])
-
- (variable_declarator
- name: (identifier) @font-lock-variable-name-face)
-
- (enum_declaration (identifier) @font-lock-type-face)
-
- (extends_clause value: (identifier) @font-lock-type-face)
- ;; extends React.Component<T>
- (extends_clause value: (member_expression
- object: (identifier) @font-lock-type-face
- property: (property_identifier)
@font-lock-type-face))
-
- (arrow_function
- parameter: (identifier) @font-lock-variable-name-face)
-
- (variable_declarator
- name: (array_pattern
- (identifier)
- (identifier) @font-lock-function-name-face)
- value: (array (number) (function)))
-
- (catch_clause
- parameter: (identifier) @font-lock-variable-name-face)
-
- ;; full module imports
- (import_clause (identifier) @font-lock-variable-name-face)
- ;; named imports with aliasing
- (import_clause (named_imports (import_specifier
- alias: (identifier)
@font-lock-variable-name-face)))
- ;; named imports without aliasing
- (import_clause (named_imports (import_specifier
- !alias
- name: (identifier)
@font-lock-variable-name-face)))
-
- ;; full namespace import (* as alias)
- (import_clause (namespace_import (identifier)
@font-lock-variable-name-face)))
-
- :language language
- :feature 'identifier
- `((nested_type_identifier
- module: (identifier) @font-lock-type-face)
-
- (type_identifier) @font-lock-type-face
-
- (predefined_type) @font-lock-type-face
-
- (new_expression
- constructor: (identifier) @font-lock-type-face)
-
- (enum_body (property_identifier) @font-lock-type-face)
-
- (enum_assignment name: (property_identifier) @font-lock-type-face)
-
- (variable_declarator
- name: (identifier) @font-lock-variable-name-face)
-
- (for_in_statement
- left: (identifier) @font-lock-variable-name-face)
-
- (arrow_function
- parameters:
- [(_ (identifier) @font-lock-variable-name-face)
- (_ (_ (identifier) @font-lock-variable-name-face))
- (_ (_ (_ (identifier) @font-lock-variable-name-face)))]))
-
- :language language
- :feature 'property
- `((property_signature
- name: (property_identifier) @font-lock-property-name-face)
- (public_field_definition
- name: (property_identifier) @font-lock-property-name-face)
-
- (pair key: (property_identifier) @font-lock-property-use-face)
-
- ((shorthand_property_identifier) @font-lock-property-use-face))
-
- :language language
- :feature 'expression
- '((assignment_expression
- left: [(identifier) @font-lock-function-name-face
- (member_expression
- property: (property_identifier) @font-lock-function-name-face)]
- right: [(function) (arrow_function)]))
-
- :language language
- :feature 'function
- '((call_expression
- function:
- [(identifier) @font-lock-function-call-face
- (member_expression
- property: (property_identifier) @font-lock-function-call-face)]))
-
- :language language
- :feature 'pattern
- `((pair_pattern
- key: (property_identifier) @font-lock-property-use-face
- value: [(identifier) @font-lock-variable-name-face
- (assignment_pattern left: (identifier)
@font-lock-variable-name-face)])
-
- (array_pattern (identifier) @font-lock-variable-name-face)
-
- ((shorthand_property_identifier_pattern) @font-lock-variable-name-face))
-
- :language language
- :feature 'jsx
- (append (tsx-ts-mode--font-lock-compatibility-bb1f97b language)
- `((jsx_attribute (property_identifier)
@typescript-ts-jsx-attribute-face)))
-
- :language language
- :feature 'number
- `((number) @font-lock-number-face
- ((identifier) @font-lock-number-face
- (:match "\\`\\(?:NaN\\|Infinity\\)\\'" @font-lock-number-face)))
-
- :language language
- :feature 'operator
- `([,@typescript-ts-mode--operators] @font-lock-operator-face
- (ternary_expression ["?" ":"] @font-lock-operator-face))
-
- :language language
- :feature 'bracket
- '((["(" ")" "[" "]" "{" "}"]) @font-lock-bracket-face)
-
- :language language
- :feature 'delimiter
- '((["," "." ";" ":"]) @font-lock-delimiter-face)
-
- :language language
- :feature 'escape-sequence
- :override t
- '((escape_sequence) @font-lock-escape-face)))
+ (let ((func-exp (tsx-ts-mode--font-lock-compatibility-function-expression
language)))
+ (treesit-font-lock-rules
+ :language language
+ :feature 'comment
+ `([(comment) (hash_bang_line)] @font-lock-comment-face)
+
+ :language language
+ :feature 'constant
+ `(((identifier) @font-lock-constant-face
+ (:match "\\`[A-Z_][0-9A-Z_]*\\'" @font-lock-constant-face))
+ [(true) (false) (null)] @font-lock-constant-face)
+
+ :language language
+ :feature 'keyword
+ `([,@typescript-ts-mode--keywords] @font-lock-keyword-face
+ [(this) (super)] @font-lock-keyword-face)
+
+ :language language
+ :feature 'string
+ `((regex pattern: (regex_pattern)) @font-lock-regexp-face
+ (string) @font-lock-string-face
+ (template_string) @js--fontify-template-string
+ (template_substitution ["${" "}"] @font-lock-misc-punctuation-face))
+
+ :language language
+ :override t ;; for functions assigned to variables
+ :feature 'declaration
+ `((,func-exp
+ name: (identifier) @font-lock-function-name-face)
+ (function_declaration
+ name: (identifier) @font-lock-function-name-face)
+ (function_signature
+ name: (identifier) @font-lock-function-name-face)
+
+ (method_definition
+ name: (property_identifier) @font-lock-function-name-face)
+ (method_signature
+ name: (property_identifier) @font-lock-function-name-face)
+ (required_parameter (identifier) @font-lock-variable-name-face)
+ (optional_parameter (identifier) @font-lock-variable-name-face)
+
+ (variable_declarator
+ name: (identifier) @font-lock-function-name-face
+ value: [(,func-exp) (arrow_function)])
+
+ (variable_declarator
+ name: (identifier) @font-lock-variable-name-face)
+
+ (enum_declaration (identifier) @font-lock-type-face)
+
+ (extends_clause value: (identifier) @font-lock-type-face)
+ ;; extends React.Component<T>
+ (extends_clause value: (member_expression
+ object: (identifier) @font-lock-type-face
+ property: (property_identifier)
@font-lock-type-face))
+
+ (arrow_function
+ parameter: (identifier) @font-lock-variable-name-face)
+
+ (variable_declarator
+ name: (array_pattern
+ (identifier)
+ (identifier) @font-lock-function-name-face)
+ value: (array (number) (,func-exp)))
+
+ (catch_clause
+ parameter: (identifier) @font-lock-variable-name-face)
+
+ ;; full module imports
+ (import_clause (identifier) @font-lock-variable-name-face)
+ ;; named imports with aliasing
+ (import_clause (named_imports (import_specifier
+ alias: (identifier)
@font-lock-variable-name-face)))
+ ;; named imports without aliasing
+ (import_clause (named_imports (import_specifier
+ !alias
+ name: (identifier)
@font-lock-variable-name-face)))
+
+ ;; full namespace import (* as alias)
+ (import_clause (namespace_import (identifier)
@font-lock-variable-name-face)))
+
+ :language language
+ :feature 'identifier
+ `((nested_type_identifier
+ module: (identifier) @font-lock-type-face)
+
+ (type_identifier) @font-lock-type-face
+
+ (predefined_type) @font-lock-type-face
+
+ (new_expression
+ constructor: (identifier) @font-lock-type-face)
+
+ (enum_body (property_identifier) @font-lock-type-face)
+
+ (enum_assignment name: (property_identifier) @font-lock-type-face)
+
+ (variable_declarator
+ name: (identifier) @font-lock-variable-name-face)
+
+ (for_in_statement
+ left: (identifier) @font-lock-variable-name-face)
+
+ (arrow_function
+ parameters:
+ [(_ (identifier) @font-lock-variable-name-face)
+ (_ (_ (identifier) @font-lock-variable-name-face))
+ (_ (_ (_ (identifier) @font-lock-variable-name-face)))]))
+
+ :language language
+ :feature 'property
+ `((property_signature
+ name: (property_identifier) @font-lock-property-name-face)
+ (public_field_definition
+ name: (property_identifier) @font-lock-property-name-face)
+
+ (pair key: (property_identifier) @font-lock-property-use-face)
+
+ ((shorthand_property_identifier) @font-lock-property-use-face))
+
+ :language language
+ :feature 'expression
+ `((assignment_expression
+ left: [(identifier) @font-lock-function-name-face
+ (member_expression
+ property: (property_identifier) @font-lock-function-name-face)]
+ right: [(,func-exp) (arrow_function)]))
+
+ :language language
+ :feature 'function
+ '((call_expression
+ function:
+ [(identifier) @font-lock-function-call-face
+ (member_expression
+ property: (property_identifier) @font-lock-function-call-face)]))
+
+ :language language
+ :feature 'pattern
+ `((pair_pattern
+ key: (property_identifier) @font-lock-property-use-face
+ value: [(identifier) @font-lock-variable-name-face
+ (assignment_pattern left: (identifier)
@font-lock-variable-name-face)])
+
+ (array_pattern (identifier) @font-lock-variable-name-face)
+
+ ((shorthand_property_identifier_pattern) @font-lock-variable-name-face))
+
+ :language language
+ :feature 'jsx
+ (append (tsx-ts-mode--font-lock-compatibility-bb1f97b language)
+ `((jsx_attribute (property_identifier)
@typescript-ts-jsx-attribute-face)))
+
+ :language language
+ :feature 'number
+ `((number) @font-lock-number-face
+ ((identifier) @font-lock-number-face
+ (:match "\\`\\(?:NaN\\|Infinity\\)\\'" @font-lock-number-face)))
+
+ :language language
+ :feature 'operator
+ `([,@typescript-ts-mode--operators] @font-lock-operator-face
+ (ternary_expression ["?" ":"] @font-lock-operator-face))
+
+ :language language
+ :feature 'bracket
+ '((["(" ")" "[" "]" "{" "}"]) @font-lock-bracket-face)
+
+ :language language
+ :feature 'delimiter
+ '((["," "." ";" ":"]) @font-lock-delimiter-face)
+
+ :language language
+ :feature 'escape-sequence
+ :override t
+ '((escape_sequence) @font-lock-escape-face))))
(defvar typescript-ts-mode--sentence-nodes
'("import_statement"
diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el
index afdf52629c4..144bfa944d3 100644
--- a/lisp/progmodes/vhdl-mode.el
+++ b/lisp/progmodes/vhdl-mode.el
@@ -8398,6 +8398,44 @@ buffer."
(message "Updating sensitivity lists...done")))
(when noninteractive (save-buffer)))
+(defun vhdl--re2-region (beg-re end-re)
+ "Return a function searching for a region delimited by a pair of regexps.
+BEG-RE and END-RE are the regexps delimiting the region to search for."
+ (lambda (proc-end)
+ (when (vhdl-re-search-forward beg-re proc-end t)
+ (save-excursion
+ (vhdl-re-search-forward end-re proc-end t)))))
+
+(defconst vhdl--signal-regions-functions
+ (list
+ ;; right-hand side of signal/variable assignment
+ ;; (special case: "<=" is relational operator in a condition)
+ (vhdl--re2-region "[<:]="
+ ";\\|\\<\\(then\\|loop\\|report\\|severity\\|is\\)\\>")
+ ;; if condition
+ (vhdl--re2-region "^\\s-*if\\>" "\\<then\\>")
+ ;; elsif condition
+ (vhdl--re2-region "\\<elsif\\>" "\\<then\\>")
+ ;; while loop condition
+ (vhdl--re2-region "^\\s-*while\\>" "\\<loop\\>")
+ ;; exit/next condition
+ (vhdl--re2-region "\\<\\(exit\\|next\\)\\s-+\\w+\\s-+when\\>" ";")
+ ;; assert condition
+ (vhdl--re2-region "\\<assert\\>" "\\(\\<report\\>\\|\\<severity\\>\\|;\\)")
+ ;; case expression
+ (vhdl--re2-region "^\\s-*case\\>" "\\<is\\>")
+ ;; parameter list of procedure call, array index
+ (lambda (proc-end)
+ (when (re-search-forward "^\\s-*\\(\\w\\|\\.\\)+[ \t\n\r\f]*(" proc-end t)
+ (forward-char -1)
+ (save-excursion
+ (forward-sexp)
+ (while (looking-at "(") (forward-sexp)) (point)))))
+ "Define syntactic regions where signals are read.
+Each function is called with one arg (a limit for the (forward) search) and
+should return either nil or the end position of the region (in which case
+point will be set to its beginning).")
+
(defun vhdl-update-sensitivity-list ()
"Update sensitivity list."
(let ((proc-beg (point))
@@ -8418,35 +8456,6 @@ buffer."
(let
;; scan for visible signals
((visible-list (vhdl-get-visible-signals))
- ;; define syntactic regions where signals are read
- (scan-regions-list
- `(;; right-hand side of signal/variable assignment
- ;; (special case: "<=" is relational operator in a condition)
- ((vhdl-re-search-forward "[<:]=" ,proc-end t)
- (vhdl-re-search-forward
";\\|\\<\\(then\\|loop\\|report\\|severity\\|is\\)\\>" ,proc-end t))
- ;; if condition
- ((vhdl-re-search-forward "^\\s-*if\\>" ,proc-end t)
- (vhdl-re-search-forward "\\<then\\>" ,proc-end t))
- ;; elsif condition
- ((vhdl-re-search-forward "\\<elsif\\>" ,proc-end t)
- (vhdl-re-search-forward "\\<then\\>" ,proc-end t))
- ;; while loop condition
- ((vhdl-re-search-forward "^\\s-*while\\>" ,proc-end t)
- (vhdl-re-search-forward "\\<loop\\>" ,proc-end t))
- ;; exit/next condition
- ((vhdl-re-search-forward
"\\<\\(exit\\|next\\)\\s-+\\w+\\s-+when\\>" ,proc-end t)
- (vhdl-re-search-forward ";" ,proc-end t))
- ;; assert condition
- ((vhdl-re-search-forward "\\<assert\\>" ,proc-end t)
- (vhdl-re-search-forward
"\\(\\<report\\>\\|\\<severity\\>\\|;\\)" ,proc-end t))
- ;; case expression
- ((vhdl-re-search-forward "^\\s-*case\\>" ,proc-end t)
- (vhdl-re-search-forward "\\<is\\>" ,proc-end t))
- ;; parameter list of procedure call, array index
- ((and (re-search-forward "^\\s-*\\(\\w\\|\\.\\)+[ \t\n\r\f]*("
,proc-end t)
- (1- (point)))
- (progn (backward-char) (forward-sexp)
- (while (looking-at "(") (forward-sexp)) (point)))))
name field read-list sens-list signal-list tmp-list
sens-beg sens-end beg end margin)
;; scan for signals in old sensitivity list
@@ -8475,11 +8484,9 @@ buffer."
(push (cons end (point)) seq-region-list)
(beginning-of-line)))
;; scan for signals read in process
- (while scan-regions-list
+ (dolist (scan-fun vhdl--signal-regions-functions)
(goto-char proc-mid)
- (while (and (setq beg (eval (nth 0 (car scan-regions-list))))
- (setq end (eval (nth 1 (car scan-regions-list)))))
- (goto-char beg)
+ (while (setq end (funcall scan-fun proc-end))
(unless (or (vhdl-in-literal)
(and seq-region-list
(let ((tmp-list seq-region-list))
@@ -8518,8 +8525,7 @@ buffer."
(car tmp-list))
(setq read-list (delete (car tmp-list) read-list)))
(setq tmp-list (cdr tmp-list)))))
- (goto-char (match-end 1)))))
- (setq scan-regions-list (cdr scan-regions-list)))
+ (goto-char (match-end 1))))))
;; update sensitivity list
(goto-char sens-beg)
(if sens-end
@@ -14978,9 +14984,9 @@ otherwise use cached data."
(vhdl-aput 'vhdl-directory-alist directory (list (list directory))))
(defun vhdl-speedbar-insert-hierarchy ( ent-alist-arg conf-alist-arg
- package-alist ent-inst-list depth)
- "Insert hierarchy of ENT-ALIST-ARG, CONF-ALIST-ARG, and PACKAGE-ALIST."
- (if (not (or ent-alist-arg conf-alist-arg package-alist))
+ pkg-alist ent-inst-list depth)
+ "Insert hierarchy of ENT-ALIST-ARG, CONF-ALIST-ARG, and PKG-ALIST."
+ (if (not (or ent-alist-arg conf-alist-arg pkg-alist))
(vhdl-speedbar-make-title-line "No VHDL design units!" depth)
(let ((ent-alist ent-alist-arg)
(conf-alist conf-alist-arg)
@@ -15010,15 +15016,15 @@ otherwise use cached data."
'vhdl-speedbar-configuration-face depth)
(setq conf-alist (cdr conf-alist)))
;; insert packages
- (when package-alist (vhdl-speedbar-make-title-line "Packages:" depth))
- (while package-alist
- (setq pack-entry (car package-alist))
+ (when pkg-alist (vhdl-speedbar-make-title-line "Packages:" depth))
+ (while pkg-alist
+ (setq pack-entry (car pkg-alist))
(vhdl-speedbar-make-pack-line
(nth 0 pack-entry) (nth 1 pack-entry)
(cons (nth 2 pack-entry) (nth 3 pack-entry))
(cons (nth 7 pack-entry) (nth 8 pack-entry))
depth)
- (setq package-alist (cdr package-alist))))))
+ (setq pkg-alist (cdr pkg-alist))))))
(declare-function speedbar-line-directory "speedbar" (&optional depth))
diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el
index bd68672f905..b36e13104e3 100644
--- a/lisp/progmodes/which-func.el
+++ b/lisp/progmodes/which-func.el
@@ -211,7 +211,7 @@ non-nil.")
(when which-function-mode
(unless (local-variable-p 'which-func-mode)
(setq which-func-mode (or (eq which-func-modes t)
- (member major-mode which-func-modes)))
+ (derived-mode-p which-func-modes)))
(setq which-func--use-mode-line
(member which-func-display '(mode mode-and-header)))
(setq which-func--use-header-line
@@ -239,7 +239,7 @@ It creates the Imenu index for the buffer, if necessary."
(condition-case err
(if (and which-func-mode
- (not (member major-mode which-func-non-auto-modes))
+ (not (derived-mode-p which-func-non-auto-modes))
(or (null which-func-maxout)
(< buffer-saved-size which-func-maxout)
(= which-func-maxout 0)))
diff --git a/lisp/server.el b/lisp/server.el
index 66e6d729f8a..b65053267a6 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -1439,7 +1439,11 @@ invocations of \"emacs\".")
;; including code that needs to wait.
(with-local-quit
(condition-case err
- (let ((buffers (server-visit-files files proc nowait)))
+ (let ((buffers (server-visit-files files proc nowait))
+ ;; On Android, the Emacs server generally can't provide
+ ;; feedback to the user except by means of dialog boxes,
+ ;; which are displayed in the GUI emacsclient wrapper.
+ (use-dialog-box-override (featurep 'android)))
(mapc 'funcall (nreverse commands))
(let ((server-eval-args-left (nreverse evalexprs)))
(while server-eval-args-left
diff --git a/lisp/simple.el b/lisp/simple.el
index 8246b9cab81..f127290231b 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -6419,7 +6419,7 @@ PROMPT is a string to prompt with."
0 (length s)
'(
keymap local-map action mouse-action
- button category help-args)
+ read-only button category help-args)
s)
s)
kill-ring))
@@ -10858,6 +10858,87 @@ and setting it to nil."
(setq-local vis-mode-saved-buffer-invisibility-spec
buffer-invisibility-spec)
(setq buffer-invisibility-spec nil)))
+
+
+(defvar read-passwd--mode-line-buffer nil
+ "Buffer to modify `mode-line-format' for showing/hiding passwords.")
+
+(defvar read-passwd--mode-line-icon nil
+ "Propertized mode line icon for showing/hiding passwords.")
+
+(defun read-passwd-toggle-visibility ()
+ "Toggle minibuffer contents visibility.
+Adapt also mode line."
+ (interactive)
+ (setq read-passwd--hide-password (not read-passwd--hide-password))
+ (with-current-buffer read-passwd--mode-line-buffer
+ (setq read-passwd--mode-line-icon
+ `(:propertize
+ ,(if icon-preference
+ (icon-string
+ (if read-passwd--hide-password
+ 'read-passwd--show-password-icon
+ 'read-passwd--hide-password-icon))
+ "")
+ mouse-face mode-line-highlight
+ local-map
+ (keymap
+ (mode-line keymap (mouse-1 . read-passwd-toggle-visibility)))))
+ (force-mode-line-update))
+ (read-passwd--hide-password))
+
+(define-minor-mode read-passwd-mode
+ "Toggle visibility of password in minibuffer."
+ :group 'mode-line
+ :group 'minibuffer
+ :keymap read-passwd-map
+ :version "30.1"
+
+ (require 'icons)
+ ;; It would be preferable to use "👁" ("\N{EYE}"). However, there is
+ ;; no corresponding Unicode char with a slash. So we use symbols as
+ ;; fallback only, with "⦵" ("\N{CIRCLE WITH HORIZONTAL BAR}") for
+ ;; hiding the password.
+ (define-icon read-passwd--show-password-icon nil
+ '((image "reveal.svg" "reveal.pbm" :height (0.8 . em))
+ (symbol "👁")
+ (text "<o>"))
+ "Mode line icon to show a hidden password."
+ :group mode-line-faces
+ :version "30.1"
+ :help-echo "mouse-1: Toggle password visibility")
+ (define-icon read-passwd--hide-password-icon nil
+ '((image "conceal.svg" "conceal.pbm" :height (0.8 . em))
+ (symbol "⦵")
+ (text "<\\>"))
+ "Mode line icon to hide a visible password."
+ :group mode-line-faces
+ :version "30.1"
+ :help-echo "mouse-1: Toggle password visibility")
+
+ (setq read-passwd--hide-password nil
+ ;; Stolen from `eldoc-minibuffer-message'.
+ read-passwd--mode-line-buffer
+ (window-buffer
+ (or (window-in-direction 'above (minibuffer-window))
+ (minibuffer-selected-window)
+ (get-largest-window))))
+
+ (if read-passwd-mode
+ (with-current-buffer read-passwd--mode-line-buffer
+ ;; Add `read-passwd--mode-line-icon'.
+ (when (listp mode-line-format)
+ (setq mode-line-format
+ (cons '(:eval read-passwd--mode-line-icon)
+ mode-line-format))))
+ (with-current-buffer read-passwd--mode-line-buffer
+ ;; Remove `read-passwd--mode-line-icon'.
+ (when (listp mode-line-format)
+ (setq mode-line-format (cdr mode-line-format)))))
+
+ (when read-passwd-mode
+ (read-passwd-toggle-visibility)))
+
(defvar messages-buffer-mode-map
(let ((map (make-sparse-keymap)))
diff --git a/lisp/sort.el b/lisp/sort.el
index 2ee76b6e1e3..4f0d759ef8a 100644
--- a/lisp/sort.el
+++ b/lisp/sort.el
@@ -478,6 +478,27 @@ sRegexp specifying key within record: \nr")
;; if there was no such register
(error (throw 'key nil))))))))))
+;;;###autoload
+(defun sort-on (sequence predicate accessor)
+ "Sort SEQUENCE by calling PREDICATE on sort keys produced by ACCESSOR.
+SEQUENCE should be the input sequence to sort.
+Elements of SEQUENCE are sorted by keys which are obtained by
+calling ACCESSOR on each element. ACCESSOR should be a function of
+one argument, an element of SEQUENCE, and should return the key
+value to be compared by PREDICATE for sorting the element.
+PREDICATE is the function for comparing keys; it is called with two
+arguments, the keys to compare, and should return non-nil if the
+first key should sort before the second key.
+The return value is always a new list.
+This function has the performance advantage of evaluating
+ACCESSOR only once for each element in the input SEQUENCE, and is
+therefore appropriate when computing the key by ACCESSOR is an
+expensive operation. This is known as the \"decorate-sort-undecorate\"
+paradigm, or the Schwartzian transform."
+ (mapcar #'car
+ (sort (mapcar #'(lambda (x) (cons x (funcall accessor x))) sequence)
+ #'(lambda (x y) (funcall predicate (cdr x) (cdr y))))))
+
(defvar sort-columns-subprocess t)
diff --git a/lisp/speedbar.el b/lisp/speedbar.el
index 1cb72dc23e6..2ed97986fe7 100644
--- a/lisp/speedbar.el
+++ b/lisp/speedbar.el
@@ -3488,7 +3488,7 @@ functions to do caching and flushing if appropriate."
nil
-(eval-when-compile (condition-case nil (require 'imenu) (error nil)))
+(eval-when-compile (require 'imenu))
(declare-function imenu--make-index-alist "imenu" (&optional no-error))
(defun speedbar-fetch-dynamic-imenu (file)
diff --git a/lisp/startup.el b/lisp/startup.el
index 23937055f30..33e1124b998 100644
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -556,6 +556,17 @@ the updated value."
(setq startup--original-eln-load-path
(copy-sequence native-comp-eln-load-path))))
+(defun startup--rescale-elt-match-p (font-pattern font-object)
+ "Test whether FONT-OBJECT matches an element of `face-font-rescale-alist'.
+FONT-OBJECT is a font-object that specifies a font to test.
+FONT-PATTERN is the car of an element of `face-font-rescale-alist',
+which can be either a regexp matching a font name or a font-spec."
+ (if (stringp font-pattern)
+ ;; FONT-PATTERN is a regexp, we need the name of FONT-OBJECT to match.
+ (string-match-p font-pattern (font-xlfd-name font-object))
+ ;; FONT-PATTERN is a font-spec.
+ (font-match-p font-pattern font-object)))
+
(defvar android-fonts-enumerated nil
"Whether or not fonts have been enumerated already.
On Android, Emacs uses this variable internally at startup.")
@@ -816,8 +827,9 @@ It is the default value of the variable `top-level'."
(when (and (display-multi-font-p)
(not (eq face-font-rescale-alist
old-face-font-rescale-alist))
- (assoc (font-xlfd-name (face-attribute 'default :font))
- face-font-rescale-alist #'string-match-p))
+ (assoc (face-attribute 'default :font)
+ face-font-rescale-alist
+ #'startup--rescale-elt-match-p))
(set-face-attribute 'default nil :font (font-spec)))
;; Modify the initial frame based on what .emacs puts into
@@ -1627,7 +1639,9 @@ Consider using a subdirectory instead, e.g.: %s"
(let ((dn (daemonp)))
(when dn
(when (stringp dn) (setq server-name dn))
- (server-start)
+ (condition-case err
+ (server-start)
+ (error (error "Unable to start daemon: %s; exiting"
(error-message-string err))))
(if server-process
(daemon-initialized)
(if (stringp dn)
@@ -1758,7 +1772,7 @@ If this is nil, no message will be displayed."
"\n"))
"A list of texts to show in the middle part of splash screens.
Each element in the list should be a list of strings or pairs
-`:face FACE', like `fancy-splash-insert' accepts them.")
+`:KEYWORD VALUE', like what `fancy-splash-insert' accepts.")
(defconst fancy-about-text
`((:face (variable-pitch font-lock-comment-face)
@@ -1851,7 +1865,7 @@ Each element in the list should be a list of strings or
pairs
"\tDisplay the Emacs manual in Info mode"))
"A list of texts to show in the middle part of the About screen.
Each element in the list should be a list of strings or pairs
-`:face FACE', like `fancy-splash-insert' accepts them.")
+`:KEYWORD VALUE', like what `fancy-splash-insert' accepts.")
(defgroup fancy-splash-screen ()
diff --git a/lisp/subr.el b/lisp/subr.el
index 33de100870e..d58f8ba3b27 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1,7 +1,6 @@
;;; subr.el --- basic lisp subroutines for Emacs -*- lexical-binding:t -*-
-;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2024 Free Software
-;; Foundation, Inc.
+;; Copyright (C) 1985-2024 Free Software Foundation, Inc.
;; Maintainer: emacs-devel@gnu.org
;; Keywords: internal
@@ -2023,6 +2022,8 @@ instead; it will indirectly limit the specpdl stack size
as well.")
(defvaralias 'native-comp-deferred-compilation 'native-comp-jit-compilation)
+(define-obsolete-function-alias 'fetch-bytecode #'ignore "30.1")
+
;;;; Alternate names for functions - these are not being phased out.
@@ -2579,6 +2580,8 @@ Affects only hooks run in the current buffer."
(list binding binding))
((null (cdr binding))
(list (make-symbol "s") (car binding)))
+ ((eq '_ (car binding))
+ (list (make-symbol "s") (cadr binding)))
(t binding)))
(when (> (length binding) 2)
(signal 'error
@@ -2619,7 +2622,7 @@ This is like `when-let' but doesn't handle a VARLIST of
the form
(defmacro and-let* (varlist &rest body)
"Bind variables according to VARLIST and conditionally evaluate BODY.
Like `when-let*', except if BODY is empty and all the bindings
-are non-nil, then the result is non-nil."
+are non-nil, then the result is the value of the last binding."
(declare (indent 1) (debug if-let*))
(let (res)
(if varlist
@@ -2632,7 +2635,8 @@ are non-nil, then the result is non-nil."
"Bind variables according to SPEC and evaluate THEN or ELSE.
Evaluate each binding in turn, as in `let*', stopping if a
binding value is nil. If all are non-nil return the value of
-THEN, otherwise the last form in ELSE.
+THEN, otherwise the value of the last form in ELSE, or nil if
+there are none.
Each element of SPEC is a list (SYMBOL VALUEFORM) that binds
SYMBOL to the value of VALUEFORM. An element can additionally be
@@ -3374,14 +3378,23 @@ with Emacs. Do not call it directly in your own
packages."
(let ((map (make-sparse-keymap)))
(set-keymap-parent map minibuffer-local-map)
(define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570
+ (define-key map "\t" #'read-passwd-toggle-visibility)
map)
"Keymap used while reading passwords.")
-(defun read-password--hide-password ()
+(defvar read-passwd--hide-password t)
+
+(defun read-passwd--hide-password ()
+ "Make password in minibuffer hidden or visible."
(let ((beg (minibuffer-prompt-end)))
(dotimes (i (1+ (- (buffer-size) beg)))
- (put-text-property (+ i beg) (+ 1 i beg)
- 'display (string (or read-hide-char ?*))))))
+ (if read-passwd--hide-password
+ (put-text-property
+ (+ i beg) (+ 1 i beg) 'display (string (or read-hide-char ?*)))
+ (remove-list-of-text-properties (+ i beg) (+ 1 i beg) '(display)))
+ (put-text-property
+ (+ i beg) (+ 1 i beg)
+ 'help-echo "C-u: Clear password\nTAB: Toggle password visibility"))))
(defun read-passwd (prompt &optional confirm default)
"Read a password, prompting with PROMPT, and return it.
@@ -3419,18 +3432,20 @@ by doing (clear-string STRING)."
(setq-local inhibit-modification-hooks nil) ;bug#15501.
(setq-local show-paren-mode nil) ;bug#16091.
(setq-local inhibit--record-char t)
- (add-hook 'post-command-hook #'read-password--hide-password nil t))
+ (read-passwd-mode 1)
+ (add-hook 'post-command-hook #'read-passwd--hide-password nil t))
(unwind-protect
(let ((enable-recursive-minibuffers t)
(read-hide-char (or read-hide-char ?*)))
(read-string prompt nil t default)) ; t = "no history"
(when (buffer-live-p minibuf)
(with-current-buffer minibuf
+ (read-passwd-mode -1)
;; Not sure why but it seems that there might be cases where the
;; minibuffer is not always properly reset later on, so undo
;; whatever we've done here (bug#11392).
(remove-hook 'after-change-functions
- #'read-password--hide-password 'local)
+ #'read-passwd--hide-password 'local)
(kill-local-variable 'post-self-insert-hook)
;; And of course, don't keep the sensitive data around.
(erase-buffer))))))))
@@ -3725,10 +3740,10 @@ There is no need to explicitly add `help-char' to CHARS;
(this-command this-command)
(result (minibuffer-with-setup-hook
(lambda ()
+ (setq-local post-self-insert-hook nil)
(add-hook 'post-command-hook
(lambda ()
- ;; FIXME: Should we use `<='?
- (if (= (1+ (minibuffer-prompt-end))
+ (if (<= (1+ (minibuffer-prompt-end))
(point-max))
(exit-minibuffer)))
nil 'local))
@@ -3828,15 +3843,25 @@ confusing to some users.")
(defvar from--tty-menu-p nil
"Non-nil means the current command was invoked from a TTY menu.")
+
+(declare-function android-detect-keyboard "androidfns.c")
+
+(defvar use-dialog-box-override nil
+ "Whether `use-dialog-box-p' should always return t.")
+
(defun use-dialog-box-p ()
"Return non-nil if the current command should prompt the user via a dialog
box."
- (and last-input-event ; not during startup
- (or (consp last-nonmenu-event) ; invoked by a mouse event
- (and (null last-nonmenu-event)
- (consp last-input-event))
- (featurep 'android) ; Prefer dialog boxes on Android.
- from--tty-menu-p) ; invoked via TTY menu
- use-dialog-box))
+ (or use-dialog-box-override
+ (and last-input-event ; not during startup
+ (or (consp last-nonmenu-event) ; invoked by a mouse event
+ (and (null last-nonmenu-event)
+ (consp last-input-event))
+ (and (featurep 'android) ; Prefer dialog boxes on
+ ; Android.
+ (not (android-detect-keyboard))) ; If no keyboard is
+ ; connected.
+ from--tty-menu-p) ; invoked via TTY menu
+ use-dialog-box)))
;; Actually in textconv.c.
(defvar overriding-text-conversion-style)
@@ -5014,7 +5039,7 @@ read-only, and scans it for function and variable names
to make them into
clickable cross-references.
See the related form `with-temp-buffer-window'."
- (declare (debug t))
+ (declare (debug t) (indent 1))
(let ((old-dir (make-symbol "old-dir"))
(buf (make-symbol "buf")))
`(let* ((,old-dir default-directory)
@@ -6734,6 +6759,8 @@ effectively rounded up."
(progress-reporter-update reporter (or current-value min-value))
reporter))
+(defalias 'progress-reporter-make #'make-progress-reporter)
+
(defun progress-reporter-force-update (reporter &optional value new-message
suffix)
"Report progress of an operation in the echo area unconditionally.
diff --git a/lisp/term/android-win.el b/lisp/term/android-win.el
index e0d252f17e0..b7b0920626e 100644
--- a/lisp/term/android-win.el
+++ b/lisp/term/android-win.el
@@ -480,5 +480,49 @@ the UTF-8 coding system."
(concat locale-base locale-modifier)))
+;; Miscellaneous functions.
+
+(declare-function android-browse-url-internal "androidselect.c")
+
+(defun android-browse-url (url &optional send)
+ "Open URL in an external application.
+
+URL should be a URL-encoded URL with a scheme specified unless
+SEND is non-nil. Signal an error upon failure.
+
+If SEND is nil, start a program that is able to display the URL,
+such as a web browser. Otherwise, try to share URL using
+programs such as email clients.
+
+If URL is a file URI, convert it into a `content' address
+accessible to other programs."
+ (when-let* ((uri (url-generic-parse-url url))
+ (filename (url-filename uri))
+ ;; If `uri' is a file URI and the file resides in /content
+ ;; or /assets, copy it to a temporary file before
+ ;; providing it to other programs.
+ (replacement-url (and (string-match-p
+ "/\\(content\\|assets\\)[/$]"
+ filename)
+ (prog1 t
+ (copy-file
+ filename
+ (setq filename
+ (make-temp-file
+ "local"
+ nil
+ (let ((extension
+ (file-name-extension
+ filename)))
+ (if extension
+ (concat "."
+ extension)
+ nil))))
+ t))
+ (concat "file://" filename))))
+ (setq url replacement-url))
+ (android-browse-url-internal url send))
+
+
(provide 'android-win)
;; android-win.el ends here.
diff --git a/lisp/textmodes/html-ts-mode.el b/lisp/textmodes/html-ts-mode.el
index 301f3e8791c..9af2aa6748f 100644
--- a/lisp/textmodes/html-ts-mode.el
+++ b/lisp/textmodes/html-ts-mode.el
@@ -121,6 +121,17 @@ Return nil if there is no name or if NODE is not a defun
node."
;; Imenu.
(setq-local treesit-simple-imenu-settings
'(("Element" "\\`tag_name\\'" nil nil)))
+
+ ;; Outline minor mode.
+ (setq-local treesit-outline-predicate "\\`element\\'")
+ ;; `html-ts-mode' inherits from `html-mode' that sets
+ ;; regexp-based outline variables. So need to restore
+ ;; the default values of outline variables to be able
+ ;; to use `treesit-outline-predicate' above.
+ (kill-local-variable 'outline-regexp)
+ (kill-local-variable 'outline-heading-end-regexp)
+ (kill-local-variable 'outline-level)
+
(treesit-major-mode-setup))
(if (treesit-ready-p 'html)
diff --git a/lisp/textmodes/pixel-fill.el b/lisp/textmodes/pixel-fill.el
index 25c0b46cee9..d26eaec2111 100644
--- a/lisp/textmodes/pixel-fill.el
+++ b/lisp/textmodes/pixel-fill.el
@@ -73,39 +73,41 @@ lines that are visually wider than PIXEL-WIDTH.
If START isn't at the start of a line, the horizontal position of
START, converted to pixel units, will be used as the indentation
prefix on subsequent lines."
- (save-excursion
- (goto-char start)
- (let ((indentation
- (car (window-text-pixel-size nil (line-beginning-position)
- (point))))
- (newline-end nil))
- (when (> indentation pixel-width)
- (error "The indentation (%s) is wider than the fill width (%s)"
- indentation pixel-width))
- (save-restriction
- (narrow-to-region start end)
- (goto-char (point-max))
- (when (looking-back "\n[ \t]*" (point-min))
- (setq newline-end t))
- (goto-char (point-min))
- ;; First replace all whitespace with space.
- (while (re-search-forward "[ \t\n]+" nil t)
- (cond
- ((or (= (match-beginning 0) start)
- (= (match-end 0) end))
- (delete-region (match-beginning 0) (match-end 0)))
- ;; If there's just a single space here, don't replace.
- ((not (and (= (- (match-end 0) (match-beginning 0)) 1)
- (= (char-after (match-beginning 0)) ?\s)))
- (replace-match
- ;; We need to use a space that has an appropriate width.
- (propertize " " 'face
- (get-text-property (match-beginning 0) 'face))))))
- (goto-char start)
- (pixel-fill--fill-line pixel-width indentation)
- (goto-char (point-max))
- (when newline-end
- (insert "\n"))))))
+ (save-window-excursion
+ (set-window-buffer nil (current-buffer))
+ (save-excursion
+ (goto-char start)
+ (let ((indentation
+ (car (window-text-pixel-size nil (line-beginning-position)
+ (point))))
+ (newline-end nil))
+ (when (> indentation pixel-width)
+ (error "The indentation (%s) is wider than the fill width (%s)"
+ indentation pixel-width))
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-max))
+ (when (looking-back "\n[ \t]*" (point-min))
+ (setq newline-end t))
+ (goto-char (point-min))
+ ;; First replace all whitespace with space.
+ (while (re-search-forward "[ \t\n]+" nil t)
+ (cond
+ ((or (= (match-beginning 0) start)
+ (= (match-end 0) end))
+ (delete-region (match-beginning 0) (match-end 0)))
+ ;; If there's just a single space here, don't replace.
+ ((not (and (= (- (match-end 0) (match-beginning 0)) 1)
+ (= (char-after (match-beginning 0)) ?\s)))
+ (replace-match
+ ;; We need to use a space that has an appropriate width.
+ (propertize " " 'face
+ (get-text-property (match-beginning 0) 'face))))))
+ (goto-char start)
+ (pixel-fill--fill-line pixel-width indentation)
+ (goto-char (point-max))
+ (when newline-end
+ (insert "\n")))))))
(defun pixel-fill--goto-pixel (width)
(vertical-motion (cons (/ width (frame-char-width)) 0)))
diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el
index a0bc5c11ece..791b10412c9 100644
--- a/lisp/textmodes/reftex-vars.el
+++ b/lisp/textmodes/reftex-vars.el
@@ -235,11 +235,10 @@ distribution. Mixed-case symbols are convenience
aliases.")
"ConTeXt bib module"
((?\C-m . "\\cite[%l]")
(?s . "\\cite[][%l]")
- (?n . "\\nocite[%l]")))
- )
+ (?n . "\\nocite[%l]"))))
"Builtin versions of the citation format.
The following conventions are valid for all alist entries:
-`?\C-m' should always point to a straight \\cite{%l} macro.
+`?\\C-m' should always point to a straight \\cite{%l} macro.
`?t' should point to a textual citation (citation as a noun).
`?p' should point to a parenthetical citation.")
diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el
index 2cd78943883..5fbff4ba888 100644
--- a/lisp/textmodes/rst.el
+++ b/lisp/textmodes/rst.el
@@ -1147,14 +1147,14 @@ as well but give an additional message."
(unless (fboundp forwarder-function)
(defalias forwarder-function
(lambda ()
+ (:documentation
+ (format "Deprecated binding for %s, use \\[%s] instead."
+ def def))
(interactive)
(call-interactively def)
(message "[Deprecated use of key %s; use key %s instead]"
(key-description (this-command-keys))
- (key-description key)))
- ;; FIXME: In Emacs-25 we could use (:documentation ...) instead.
- (format "Deprecated binding for %s, use \\[%s] instead."
- def def)))
+ (key-description key)))))
(dolist (dep-key deprecated)
(define-key keymap dep-key forwarder-function)))))
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
index 8968d8ec23b..616b8871090 100644
--- a/lisp/textmodes/tex-mode.el
+++ b/lisp/textmodes/tex-mode.el
@@ -511,17 +511,26 @@ An alternative value is \" . \", if you use a font with a
narrow period."
;; This would allow highlighting \newcommand\CMD but requires
;; adapting subgroup numbers below.
;; (arg
"\\(?:{\\(\\(?:[^{}\\]+\\|\\\\.\\|{[^}]*}\\)+\\)\\|\\\\[a-z*]+\\)"))
- (inbraces-re (lambda (re)
- (concat "\\(?:[^{}\\]\\|\\\\.\\|" re "\\)")))
- (arg (concat "{\\(" (funcall inbraces-re "{[^}]*}") "+\\)")))
- `( ;; Highlight $$math$$ and $math$.
+ (inbraces-re
+ (lambda (n) ;; Level of nesting of braces we should support.
+ (let ((re "[^}]"))
+ (dotimes (_ n)
+ (setq re
+ (concat "\\(?:[^{}\\]\\|\\\\.\\|{" re "*}\\)")))
+ re)))
+ (arg (concat "{\\(" (funcall inbraces-re 2) "+\\)")))
+ `(;; Verbatim-like args.
+ ;; Do it first, because we don't want to highlight them
+ ;; in comments (bug#68827), but we do want to highlight them
+ ;; in $math$.
+ (,(concat slash verbish opt arg) 3 'tex-verbatim keep)
+ ;; Highlight $$math$$ and $math$.
;; This is done at the very beginning so as to interact with the other
;; keywords in the same way as comments and strings.
(,(concat "\\$\\$?\\(?:[^$\\{}]\\|\\\\.\\|{"
- (funcall inbraces-re
- (concat "{" (funcall inbraces-re "{[^}]*}") "*}"))
+ (funcall inbraces-re 6)
"*}\\)+\\$?\\$")
- (0 'tex-math))
+ (0 'tex-math keep))
;; Heading args.
(,(concat slash headings "\\*?" opt arg)
;; If ARG ends up matching too much (if the {} don't match, e.g.)
@@ -543,8 +552,6 @@ An alternative value is \" . \", if you use a font with a
narrow period."
(,(concat slash variables " *" arg) 2 font-lock-variable-name-face)
;; Include args.
(,(concat slash includes opt arg) 3 font-lock-builtin-face)
- ;; Verbatim-like args.
- (,(concat slash verbish opt arg) 3 'tex-verbatim t)
;; Definitions. I think.
("^[ \t]*\\\\def *\\\\\\(\\(\\w\\|@\\)+\\)"
1 font-lock-function-name-face))))
@@ -602,14 +609,14 @@ An alternative value is \" . \", if you use a font with a
narrow period."
(list (concat (regexp-opt '("``" "\"<" "\"`" "<<" "«") t)
"\\(\\(.\\|\n\\)+?\\)"
(regexp-opt `("''" "\">" "\"'" ">>" "»") t))
- '(1 font-lock-keyword-face)
- '(2 font-lock-string-face)
- '(4 font-lock-keyword-face))
+ '(1 'font-lock-keyword-face)
+ '(2 'font-lock-string-face)
+ '(4 'font-lock-keyword-face))
;;
;; Command names, special and general.
(cons (concat slash specials-1) 'font-lock-warning-face)
(list (concat "\\(" slash specials-2 "\\)\\([^a-zA-Z@]\\|\\'\\)")
- 1 'font-lock-warning-face)
+ '(1 'font-lock-warning-face))
(concat slash general)
;;
;; Font environments. It seems a bit dubious to use `bold' etc. faces
@@ -677,7 +684,7 @@ An alternative value is \" . \", if you use a font with a
narrow period."
(eval-when-compile
(defconst tex-syntax-propertize-rules
(syntax-propertize-precompile-rules
- ("\\\\verb\\**\\([^a-z@*]\\)"
+ ("\\\\verb\\**\\([^a-z@*]\\)"
(1 (prog1 "\""
(tex-font-lock-verb
(match-beginning 0) (char-after (match-beginning 1))))))))
@@ -761,7 +768,7 @@ automatically inserts its partner."
(regexp-quote (buffer-substring arg-start arg-end)))
(text-clone-create arg-start arg-end))))))))
(scan-error nil)
- (error (message "Error in latex-env-before-change: %s" err)))))
+ (error (message "Error in latex-env-before-change: %S" err)))))
(defun tex-font-lock-unfontify-region (beg end)
(font-lock-default-unfontify-region beg end)
@@ -849,7 +856,7 @@ START is the position of the \\ and DELIM is the delimiter
char."
(let ((char (nth 3 state)))
(cond
((not char)
- (if (eq 2 (nth 7 state)) 'tex-verbatim font-lock-comment-face))
+ (if (eq 2 (nth 7 state)) 'tex-verbatim 'font-lock-comment-face))
((eq char ?$) 'tex-math)
;; A \verb element.
(t 'tex-verbatim))))
@@ -1262,8 +1269,8 @@ Entering SliTeX mode runs the hook `text-mode-hook', then
the hook
(setq-local facemenu-end-add-face "}")
(setq-local facemenu-remove-face-function t)
(setq-local font-lock-defaults
- '((tex-font-lock-keywords tex-font-lock-keywords-1
- tex-font-lock-keywords-2
tex-font-lock-keywords-3)
+ '(( tex-font-lock-keywords tex-font-lock-keywords-1
+ tex-font-lock-keywords-2 tex-font-lock-keywords-3)
nil nil nil nil
;; Who ever uses that anyway ???
(font-lock-mark-block-function . mark-paragraph)
diff --git a/lisp/textmodes/text-mode.el b/lisp/textmodes/text-mode.el
index 87f6668cecb..e8e1f4898ce 100644
--- a/lisp/textmodes/text-mode.el
+++ b/lisp/textmodes/text-mode.el
@@ -88,7 +88,7 @@ nor does it extend `completion-at-point-functions'.
This user option only takes effect when you customize it in
Custom or with `setopt', not with `setq'."
:group 'text
- :type 'boolean
+ :type '(choice (const completion-at-point) boolean)
:version "30.1"
:set (lambda (sym val)
(if (and (set sym val)
diff --git a/lisp/textmodes/yaml-ts-mode.el b/lisp/textmodes/yaml-ts-mode.el
index c0185457bc2..a8cb504ef03 100644
--- a/lisp/textmodes/yaml-ts-mode.el
+++ b/lisp/textmodes/yaml-ts-mode.el
@@ -128,7 +128,7 @@ boundaries. JUSTIFY is passed to `fill-paragraph'."
(save-restriction
(widen)
(let ((node (treesit-node-at (point))))
- (when (string= "block_scalar" (treesit-node-type node))
+ (if (member (treesit-node-type node) '("block_scalar" "comment"))
(let* ((start (treesit-node-start node))
(end (treesit-node-end node))
(start-marker (point-marker))
@@ -138,7 +138,8 @@ boundaries. JUSTIFY is passed to `fill-paragraph'."
(forward-line)
(move-marker start-marker (point))
(narrow-to-region (point) end))
- (fill-region start-marker end justify))))))
+ (fill-region start-marker end justify))
+ t))))
;;;###autoload
(define-derived-mode yaml-ts-mode text-mode "YAML"
diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el
index 323d3d1cf6c..83ddc640d35 100644
--- a/lisp/thingatpt.el
+++ b/lisp/thingatpt.el
@@ -619,36 +619,20 @@ point.
Optional argument DISTANCE limits search for REGEXP forward and
back from point."
- (save-excursion
- (let ((old-point (point))
- (forward-bound (and distance (+ (point) distance)))
- (backward-bound (and distance (- (point) distance)))
- match prev-pos new-pos)
- (and (looking-at regexp)
- (>= (match-end 0) old-point)
- (setq match (point)))
- ;; Search back repeatedly from end of next match.
- ;; This may fail if next match ends before this match does.
- (re-search-forward regexp forward-bound 'limit)
- (setq prev-pos (point))
- (while (and (setq new-pos (re-search-backward regexp backward-bound t))
- ;; Avoid inflooping with some regexps, such as "^",
- ;; matching which never moves point.
- (< new-pos prev-pos)
- (or (> (match-beginning 0) old-point)
- (and (looking-at regexp) ; Extend match-end past search
start
- (>= (match-end 0) old-point)
- (setq match (point))))))
- (if (not match) nil
- (goto-char match)
- ;; Back up a char at a time in case search skipped
- ;; intermediate match straddling search start pos.
- (while (and (not (bobp))
- (progn (backward-char 1) (looking-at regexp))
- (>= (match-end 0) old-point)
- (setq match (point))))
- (goto-char match)
- (looking-at regexp)))))
+ (let* ((old (point))
+ (beg (if distance (max (point-min) (- old distance)) (point-min)))
+ (end (if distance (min (point-max) (+ old distance))))
+ prev match)
+ (save-excursion
+ (goto-char beg)
+ (while (and (setq prev (point)
+ match (re-search-forward regexp end t))
+ (< (match-end 0) old))
+ (goto-char (match-beginning 0))
+ ;; Avoid inflooping when `regexp' matches the empty string.
+ (unless (< prev (point)) (forward-char))))
+ (and match (<= (match-beginning 0) old (match-end 0)))))
+
;; Email addresses
(defvar thing-at-point-email-regexp
diff --git a/lisp/touch-screen.el b/lisp/touch-screen.el
index a1ec4bca89f..c8de1d8ee31 100644
--- a/lisp/touch-screen.el
+++ b/lisp/touch-screen.el
@@ -87,7 +87,7 @@ is being called from `read-sequence' or some similar
function.")
(defgroup touch-screen nil
"Interact with Emacs from touch screen devices."
:group 'mouse
- :version "30.0")
+ :version "30.1")
(defcustom touch-screen-display-keyboard nil
"If non-nil, always display the on screen keyboard.
diff --git a/lisp/transient.el b/lisp/transient.el
index f9060f5ba85..bb35746e186 100644
--- a/lisp/transient.el
+++ b/lisp/transient.el
@@ -855,7 +855,6 @@ elements themselves.")
;;; Define
-;;;###autoload
(defmacro transient-define-prefix (name arglist &rest args)
"Define NAME as a transient prefix command.
diff --git a/lisp/treesit.el b/lisp/treesit.el
index 96222ed81cb..fa82ad898a9 100644
--- a/lisp/treesit.el
+++ b/lisp/treesit.el
@@ -344,14 +344,13 @@ ancestor node which satisfies the predicate PRED; then it
returns that ancestor node. It returns nil if no ancestor
node was found that satisfies PRED.
-PRED should be a function that takes one argument, the node to
-examine, and returns a boolean value indicating whether that
-node is a match.
+PRED can be a predicate function, a regexp matching node type,
+and more; see docstring of `treesit-thing-settings'.
If INCLUDE-NODE is non-nil, return NODE if it satisfies PRED."
(let ((node (if include-node node
(treesit-node-parent node))))
- (while (and node (not (funcall pred node)))
+ (while (and node (not (treesit-node-match-p node pred)))
(setq node (treesit-node-parent node)))
node))
@@ -364,11 +363,10 @@ no longer satisfies the predicate PRED; it returns the
last
examined node that satisfies PRED. If no node satisfies PRED, it
returns nil.
-PRED should be a function that takes one argument, the node to
-examine, and returns a boolean value indicating whether that
-node is a match."
+PRED can be a predicate function, a regexp matching node type,
+and more; see docstring of `treesit-thing-settings'."
(let ((last nil))
- (while (and node (funcall pred node))
+ (while (and node (treesit-node-match-p node pred))
(setq last node
node (treesit-node-parent node)))
last))
@@ -655,37 +653,47 @@ those inside are kept."
if (<= start (car range) (cdr range) end)
collect range))
-(defun treesit-local-parsers-at (&optional pos language)
+(defun treesit-local-parsers-at (&optional pos language with-host)
"Return all the local parsers at POS.
POS defaults to point.
Local parsers are those which only parse a limited region marked
by an overlay with non-nil `treesit-parser' property.
-If LANGUAGE is non-nil, only return parsers for LANGUAGE."
+If LANGUAGE is non-nil, only return parsers for LANGUAGE.
+
+If WITH-HOST is non-nil, return a list of (PARSER . HOST-PARSER)
+instead. HOST-PARSER is the host parser which created the local
+PARSER."
(let ((res nil))
(dolist (ov (overlays-at (or pos (point))))
- (when-let ((parser (overlay-get ov 'treesit-parser)))
+ (when-let ((parser (overlay-get ov 'treesit-parser))
+ (host-parser (overlay-get ov 'treesit-host-parser)))
(when (or (null language)
(eq (treesit-parser-language parser)
language))
- (push parser res))))
+ (push (if with-host (cons parser host-parser) parser) res))))
(nreverse res)))
-(defun treesit-local-parsers-on (&optional beg end language)
+(defun treesit-local-parsers-on (&optional beg end language with-host)
"Return all the local parsers between BEG END.
BEG and END default to the beginning and end of the buffer's
accessible portion.
Local parsers are those which have an `embedded' tag, and only parse
a limited region marked by an overlay with a non-nil `treesit-parser'
-property. If LANGUAGE is non-nil, only return parsers for LANGUAGE."
+property. If LANGUAGE is non-nil, only return parsers for LANGUAGE.
+
+If WITH-HOST is non-nil, return a list of (PARSER . HOST-PARSER)
+instead. HOST-PARSER is the host parser which created the local
+PARSER."
(let ((res nil))
(dolist (ov (overlays-in (or beg (point-min)) (or end (point-max))))
- (when-let ((parser (overlay-get ov 'treesit-parser)))
+ (when-let ((parser (overlay-get ov 'treesit-parser))
+ (host-parser (overlay-get ov 'treesit-host-parser)))
(when (or (null language)
(eq (treesit-parser-language parser)
language))
- (push parser res))))
+ (push (if with-host (cons parser host-parser) parser) res))))
(nreverse res)))
(defun treesit--update-ranges-local
@@ -701,7 +709,8 @@ parser for EMBEDDED-LANG."
(treesit-parser-delete parser))))
;; Update range.
(let* ((host-lang (treesit-query-language query))
- (ranges (treesit-query-range host-lang query beg end)))
+ (host-parser (treesit-parser-create host-lang))
+ (ranges (treesit-query-range host-parser query beg end)))
(pcase-dolist (`(,beg . ,end) ranges)
(let ((has-parser nil))
(dolist (ov (overlays-in beg end))
@@ -719,6 +728,7 @@ parser for EMBEDDED-LANG."
embedded-lang nil t 'embedded))
(ov (make-overlay beg end nil nil t)))
(overlay-put ov 'treesit-parser embedded-parser)
+ (overlay-put ov 'treesit-host-parser host-parser)
(treesit-parser-set-included-ranges
embedded-parser `((,beg . ,end)))))))))
@@ -1372,7 +1382,15 @@ as comment due to incomplete parse tree."
;; `treesit-update-ranges' will force the host language's parser to
;; reparse and set correct ranges for embedded parsers. Then
;; `treesit-parser-root-node' will force those parsers to reparse.
- (treesit-update-ranges)
+ (let ((len (+ (* (window-body-height) (window-body-width)) 800)))
+ ;; FIXME: As a temporary fix, this prevents Emacs from updating
+ ;; every single local parsers in the buffer every time there's an
+ ;; edit. Moving forward, we need some way to properly track the
+ ;; regions which need update on parser ranges, like what jit-lock
+ ;; and syntax-ppss does.
+ (treesit-update-ranges
+ (max (point-min) (- (point) len))
+ (min (point-max) (+ (point) len))))
;; Force repase on _all_ the parsers might not be necessary, but
;; this is probably the most robust way.
(dolist (parser (treesit-parser-list))
@@ -1800,11 +1818,17 @@ Return (ANCHOR . OFFSET). This function is used by
(forward-line 0)
(skip-chars-forward " \t")
(point)))
- (local-parsers (treesit-local-parsers-at bol))
+ (local-parsers (treesit-local-parsers-at bol nil t))
(smallest-node
- (cond ((null (treesit-parser-list)) nil)
- (local-parsers (treesit-node-at
- bol (car local-parsers)))
+ (cond ((car local-parsers)
+ (let ((local-parser (caar local-parsers))
+ (host-parser (cdar local-parsers)))
+ (if (eq (treesit-node-start
+ (treesit-parser-root-node local-parser))
+ bol)
+ (treesit-node-at bol host-parser)
+ (treesit-node-at bol local-parser))))
+ ((null (treesit-parser-list)) nil)
((eq 1 (length (treesit-parser-list nil nil t)))
(treesit-node-at bol))
((treesit-language-at bol)
@@ -2644,9 +2668,17 @@ function is called recursively."
(setq parent (treesit-node-top-level parent thing t)
prev nil
next nil))
- ;; If TACTIC is `restricted', the implementation is very simple.
+ ;; If TACTIC is `restricted', the implementation is simple.
+ ;; In principle we don't go to parent's beg/end for
+ ;; `restricted' tactic, but if the parent is a "leaf thing"
+ ;; (doesn't have any child "thing" inside it), then we can
+ ;; move to the beg/end of it (bug#68899).
(if (eq tactic 'restricted)
- (setq pos (funcall advance (if (> arg 0) next prev)))
+ (setq pos (funcall
+ advance
+ (cond ((and (null next) (null prev)) parent)
+ ((> arg 0) next)
+ (t prev))))
;; For `nested', it's a bit more work:
;; Move...
(if (> arg 0)
@@ -2836,6 +2868,71 @@ ENTRY. MARKER marks the start of each tree-sitter node."
index))))
treesit-simple-imenu-settings)))
+;;; Outline minor mode
+
+(defvar-local treesit-outline-predicate nil
+ "Predicate used to find outline headings in the syntax tree.
+The predicate can be a function, a regexp matching node type,
+and more; see docstring of `treesit-thing-settings'.
+It matches the nodes located on lines with outline headings.
+Intended to be set by a major mode. When nil, the predicate
+is constructed from the value of `treesit-simple-imenu-settings'
+when a major mode sets it.")
+
+(defun treesit-outline-predicate--from-imenu (node)
+ ;; Return an outline searching predicate created from Imenu.
+ ;; Return the value suitable to set `treesit-outline-predicate'.
+ ;; Create this predicate from the value `treesit-simple-imenu-settings'
+ ;; that major modes set to find Imenu entries. The assumption here
+ ;; is that the positions of Imenu entries most of the time coincide
+ ;; with the lines of outline headings. When this assumption fails,
+ ;; you can directly set a proper value to `treesit-outline-predicate'.
+ (seq-some
+ (lambda (setting)
+ (and (string-match-p (nth 1 setting) (treesit-node-type node))
+ (or (null (nth 2 setting))
+ (funcall (nth 2 setting) node))))
+ treesit-simple-imenu-settings))
+
+(defun treesit-outline-search (&optional bound move backward looking-at)
+ "Search for the next outline heading in the syntax tree.
+See the descriptions of arguments in `outline-search-function'."
+ (if looking-at
+ (when-let* ((node (or (treesit--thing-at (pos-eol)
treesit-outline-predicate)
+ (treesit--thing-at (pos-bol)
treesit-outline-predicate)))
+ (start (treesit-node-start node)))
+ (eq (pos-bol) (save-excursion (goto-char start) (pos-bol))))
+
+ (let* ((pos
+ ;; When function wants to find the current outline, point
+ ;; is at the beginning of the current line. When it wants
+ ;; to find the next outline, point is at the second column.
+ (if (eq (point) (pos-bol))
+ (if (bobp) (point) (1- (point)))
+ (pos-eol)))
+ (found (treesit--navigate-thing pos (if backward -1 1) 'beg
+ treesit-outline-predicate)))
+ (if found
+ (if (or (not bound) (if backward (>= found bound) (<= found bound)))
+ (progn
+ (goto-char found)
+ (goto-char (pos-bol))
+ (set-match-data (list (point) (pos-eol)))
+ t)
+ (when move (goto-char bound))
+ nil)
+ (when move (goto-char (or bound (if backward (point-min)
(point-max)))))
+ nil))))
+
+(defun treesit-outline-level ()
+ "Return the depth of the current outline heading."
+ (let* ((node (treesit-node-at (point) nil t))
+ (level (if (treesit-node-match-p node treesit-outline-predicate)
+ 1 0)))
+ (while (setq node (treesit-parent-until node treesit-outline-predicate))
+ (setq level (1+ level)))
+ (if (zerop level) 1 level)))
+
;;; Activating tree-sitter
(defun treesit-ready-p (language &optional quiet)
@@ -2966,6 +3063,17 @@ before calling this function."
(setq-local imenu-create-index-function
#'treesit-simple-imenu))
+ ;; Outline minor mode.
+ (when (and (or treesit-outline-predicate treesit-simple-imenu-settings)
+ (not (seq-some #'local-variable-p
+ '(outline-search-function
+ outline-regexp outline-level))))
+ (unless treesit-outline-predicate
+ (setq treesit-outline-predicate
+ #'treesit-outline-predicate--from-imenu))
+ (setq-local outline-search-function #'treesit-outline-search
+ outline-level #'treesit-outline-level))
+
;; Remove existing local parsers.
(dolist (ov (overlays-in (point-min) (point-max)))
(when-let ((parser (overlay-get ov 'treesit-parser)))
diff --git a/lisp/url/url-cid.el b/lisp/url/url-cid.el
index 17a0318e652..d80037f8fe9 100644
--- a/lisp/url/url-cid.el
+++ b/lisp/url/url-cid.el
@@ -1,6 +1,6 @@
;;; url-cid.el --- Content-ID URL loader -*- lexical-binding: t; -*-
-;; Copyright (C) 1998-1999, 2004-2024 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -52,12 +52,7 @@
;;;###autoload
(defun url-cid (url)
- (cond
- ((fboundp 'mm-get-content-id)
- ;; Using Pterodactyl Gnus or later
- (with-current-buffer (generate-new-buffer " *url-cid*")
- (url-cid-gnus (url-filename url))))
- (t
- (message "Unable to handle CID URL: %s" url))))
+ (with-current-buffer (generate-new-buffer " *url-cid*")
+ (url-cid-gnus (url-filename url))))
;;; url-cid.el ends here
diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el
index d6a1d0eade8..184c1278072 100644
--- a/lisp/url/url-http.el
+++ b/lisp/url/url-http.el
@@ -427,7 +427,7 @@ Use `url-http-referer' as the Referer-header (subject to
`url-privacy-level')."
;; Parsing routines
(defun url-http-clean-headers ()
- "Remove trailing \r from header lines.
+ "Remove trailing \\r from header lines.
This allows us to use `mail-fetch-field', etc.
Return the number of characters removed."
(let ((end (marker-position url-http-end-of-headers)))
diff --git a/lisp/url/url-ldap.el b/lisp/url/url-ldap.el
index 1bdd5099637..6aaea606c27 100644
--- a/lisp/url/url-ldap.el
+++ b/lisp/url/url-ldap.el
@@ -1,6 +1,6 @@
;;; url-ldap.el --- LDAP Uniform Resource Locator retrieval code -*-
lexical-binding: t; -*-
-;; Copyright (C) 1998-1999, 2004-2024 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -92,12 +92,8 @@
"'>" dn "</a>"))
(defun url-ldap-certificate-formatter (data)
- (condition-case ()
- (require 'ssl)
- (error nil))
- (let ((vals (if (fboundp 'ssl-certificate-information)
- (ssl-certificate-information data)
- (tls-certificate-information data))))
+ ;; FIXME: tls.el is obsolete.
+ (let ((vals (tls-certificate-information data)))
(if (not vals)
"<b>Unable to parse certificate</b>"
(concat "<table border=0>\n"
diff --git a/lisp/url/url-mailto.el b/lisp/url/url-mailto.el
index c2d347a1646..50293ab3f05 100644
--- a/lisp/url/url-mailto.el
+++ b/lisp/url/url-mailto.el
@@ -1,6 +1,6 @@
;;; url-mailto.el --- Mail Uniform Resource Locator retrieval code -*-
lexical-binding: t; -*-
-;; Copyright (C) 1996-1999, 2004-2024 Free Software Foundation, Inc.
+;; Copyright (C) 1996-2024 Free Software Foundation, Inc.
;; Keywords: comm, data, processes
@@ -28,12 +28,7 @@
(require 'url-util)
;;;###autoload
-(defun url-mail (&rest args)
- (interactive "P")
- (if (fboundp 'message-mail)
- (apply 'message-mail args)
- (or (apply 'mail args)
- (error "Mail aborted"))))
+(defalias 'url-mail #'message-mail)
(defun url-mail-goto-field (field)
(if (not field)
@@ -57,8 +52,6 @@
(save-excursion
(insert "\n"))))))
-(declare-function mail-send-and-exit "sendmail")
-
;;;###autoload
(defun url-mailto (url)
"Handle the mailto: URL syntax."
@@ -111,8 +104,6 @@
;; (setq func (intern-soft (concat "mail-" (caar args))))
(insert (mapconcat 'identity (cdar args) ", ")))
(setq args (cdr args)))
- ;; (url-mail-goto-field "User-Agent")
-;; (insert url-package-name "/" url-package-version " URL/" url-version)
(if (not url-request-data)
(progn
(set-buffer-modified-p nil)
@@ -128,8 +119,8 @@
(goto-char (point-max))
(insert url-request-data)
;; It seems Microsoft-ish to send without warning.
- ;; Fixme: presumably this should depend on a privacy setting.
- (if (y-or-n-p "Send this auto-generated mail? ")
+ ;; FIXME: presumably this should depend on a privacy setting.
+ (if (y-or-n-p "Send this auto-generated mail?")
(let ((buffer (current-buffer)))
(cond ((eq url-mail-command 'compose-mail)
(funcall (get mail-user-agent 'sendfunc) nil))
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 83d580d98dd..99ac50c155a 100644
--- a/lisp/vc/diff-mode.el
+++ b/lisp/vc/diff-mode.el
@@ -517,8 +517,8 @@ use the face `diff-removed' for removed lines, and the face
("^Only in .*\n" . 'diff-nonexistent)
("^Binary files .* differ\n" . 'diff-file-header)
("^\\(#\\)\\(.*\\)"
- (1 font-lock-comment-delimiter-face)
- (2 font-lock-comment-face))
+ (1 'font-lock-comment-delimiter-face)
+ (2 'font-lock-comment-face))
("^diff: .*" (0 'diff-error))
("^[^-=+*!<>#].*\n" (0 'diff-context))
(,#'diff--font-lock-syntax)
@@ -944,7 +944,8 @@ like \(diff-merge-strings \"b/foo\" \"b/bar\"
\"/a/c/foo\")."
(when (and (string-match (concat
"\\`\\(.*?\\)\\(.*\\)\\(.*\\)\n"
"\\1\\(.*\\)\\3\n"
- "\\(.*\\(\\2\\).*\\)\\'") str)
+ "\\(.*\\(\\2\\).*\\)\\'")
+ str)
(equal to (match-string 5 str)))
(concat (substring str (match-beginning 5) (match-beginning 6))
(match-string 4 str)
@@ -1999,7 +2000,7 @@ With a prefix argument, REVERSE the hunk."
(diff-find-source-location nil reverse)))
(cond
((null line-offset)
- (error "Can't find the text to patch"))
+ (user-error "Can't find the text to patch"))
((with-current-buffer buf
(and buffer-file-name
(backup-file-name-p buffer-file-name)
@@ -2008,7 +2009,7 @@ With a prefix argument, REVERSE the hunk."
(yes-or-no-p (format "Really apply this hunk to
%s? "
(file-name-nondirectory
buffer-file-name)))))))
- (error "%s"
+ (user-error "%s"
(substitute-command-keys
(format "Use %s\\[diff-apply-hunk] to apply it to the other file"
(if (not reverse) "\\[universal-argument] ")))))
@@ -2275,6 +2276,24 @@ Return new point, if it was moved."
(end (progn (diff-end-of-hunk) (point))))
(diff--refine-hunk beg end)))))
+(defun diff--refine-propertize (beg end face)
+ (let ((ol (make-overlay beg end)))
+ (overlay-put ol 'diff-mode 'fine)
+ (overlay-put ol 'evaporate t)
+ (overlay-put ol 'face face)))
+
+(defcustom diff-refine-nonmodified nil
+ "If non-nil, also highlight the added/removed lines as \"refined\".
+The lines highlighted when this is non-nil are those that were
+added or removed in their entirety, as opposed to lines some
+parts of which were modified. The added lines are highlighted
+using the `diff-refine-added' face, while the removed lines are
+highlighted using the `diff-refine-removed' face.
+This is currently implemented only for diff formats supported
+by `diff-refine-hunk'."
+ :version "30.1"
+ :type 'boolean)
+
(defun diff--refine-hunk (start end)
(require 'smerge-mode)
(goto-char start)
@@ -2289,41 +2308,68 @@ Return new point, if it was moved."
(goto-char beg)
(pcase style
('unified
- (while (re-search-forward "^-" end t)
+ (while (re-search-forward "^[-+]" end t)
(let ((beg-del (progn (beginning-of-line) (point)))
beg-add end-add)
- (when (and (diff--forward-while-leading-char ?- end)
- ;; Allow for "\ No newline at end of file".
- (progn (diff--forward-while-leading-char ?\\ end)
- (setq beg-add (point)))
- (diff--forward-while-leading-char ?+ end)
- (progn (diff--forward-while-leading-char ?\\ end)
- (setq end-add (point))))
+ (cond
+ ((eq (char-after) ?+)
+ (diff--forward-while-leading-char ?+ end)
+ (when diff-refine-nonmodified
+ (diff--refine-propertize beg-del (point) 'diff-refine-added)))
+ ((and (diff--forward-while-leading-char ?- end)
+ ;; Allow for "\ No newline at end of file".
+ (progn (diff--forward-while-leading-char ?\\ end)
+ (setq beg-add (point)))
+ (diff--forward-while-leading-char ?+ end)
+ (progn (diff--forward-while-leading-char ?\\ end)
+ (setq end-add (point))))
(smerge-refine-regions beg-del beg-add beg-add end-add
- nil #'diff-refine-preproc props-r
props-a)))))
+ nil #'diff-refine-preproc props-r props-a))
+ (t ;; If we're here, it's because
+ ;; (diff--forward-while-leading-char ?+ end) failed.
+ (when diff-refine-nonmodified
+ (diff--refine-propertize beg-del (point)
+ 'diff-refine-removed)))))))
('context
(let* ((middle (save-excursion (re-search-forward "^---" end t)))
(other middle))
- (while (and middle
- (re-search-forward "^\\(?:!.*\n\\)+" middle t))
- (smerge-refine-regions (match-beginning 0) (match-end 0)
- (save-excursion
- (goto-char other)
- (re-search-forward "^\\(?:!.*\n\\)+" end)
- (setq other (match-end 0))
- (match-beginning 0))
- other
- (if diff-use-changed-face props-c)
- #'diff-refine-preproc
- (unless diff-use-changed-face props-r)
- (unless diff-use-changed-face props-a)))))
+ (when middle
+ (while (re-search-forward "^\\(?:!.*\n\\)+" middle t)
+ (smerge-refine-regions (match-beginning 0) (match-end 0)
+ (save-excursion
+ (goto-char other)
+ (re-search-forward "^\\(?:!.*\n\\)+" end)
+ (setq other (match-end 0))
+ (match-beginning 0))
+ other
+ (if diff-use-changed-face props-c)
+ #'diff-refine-preproc
+ (unless diff-use-changed-face props-r)
+ (unless diff-use-changed-face props-a)))
+ (when diff-refine-nonmodified
+ (goto-char beg)
+ (while (re-search-forward "^\\(?:-.*\n\\)+" middle t)
+ (diff--refine-propertize (match-beginning 0)
+ (match-end 0)
+ 'diff-refine-removed))
+ (goto-char middle)
+ (while (re-search-forward "^\\(?:+.*\n\\)+" end t)
+ (diff--refine-propertize (match-beginning 0)
+ (match-end 0)
+ 'diff-refine-added))))))
(_ ;; Normal diffs.
(let ((beg1 (1+ (point))))
- (when (re-search-forward "^---.*\n" end t)
+ (cond
+ ((re-search-forward "^---.*\n" end t)
;; It's a combined add&remove, so there's something to do.
(smerge-refine-regions beg1 (match-beginning 0)
(match-end 0) end
- nil #'diff-refine-preproc props-r
props-a)))))))
+ nil #'diff-refine-preproc props-r props-a))
+ (diff-refine-nonmodified
+ (diff--refine-propertize
+ beg1 end
+ (if (eq (char-after beg1) ?<)
+ 'diff-refine-removed 'diff-refine-added)))))))))
(defun diff--iterate-hunks (max fun)
"Iterate over all hunks between point and MAX.
@@ -2817,6 +2863,57 @@ and the position in MAX."
(defvar-local diff--syntax-file-attributes nil)
(put 'diff--syntax-file-attributes 'permanent-local t)
+(defvar diff--cached-revision-buffers nil
+ "List of ((FILE . REVISION) . BUFFER) in MRU order.")
+
+(defvar diff--cache-clean-timer nil)
+(defconst diff--cache-clean-interval 3600) ; seconds
+
+(defun diff--cache-clean ()
+ "Discard the least recently used half of the cache."
+ (let ((n (/ (length diff--cached-revision-buffers) 2)))
+ (mapc #'kill-buffer (mapcar #'cdr (nthcdr n
diff--cached-revision-buffers)))
+ (setq diff--cached-revision-buffers
+ (ntake n diff--cached-revision-buffers)))
+ (diff--cache-schedule-clean))
+
+(defun diff--cache-schedule-clean ()
+ (setq diff--cache-clean-timer
+ (and diff--cached-revision-buffers
+ (run-with-timer diff--cache-clean-interval nil
+ #'diff--cache-clean))))
+
+(defun diff--get-revision-properties (file revision text line-nb)
+ "Get font-lock properties from FILE at REVISION for TEXT at LINE-NB."
+ (let* ((file-rev (cons file revision))
+ (entry (assoc file-rev diff--cached-revision-buffers))
+ (buffer (cdr entry)))
+ (if (buffer-live-p buffer)
+ (progn
+ ;; Don't re-initialize the buffer (which would throw
+ ;; away the previous fontification work).
+ (setq file nil)
+ (setq diff--cached-revision-buffers
+ (cons entry
+ (delq entry diff--cached-revision-buffers))))
+ ;; Cache miss: create a new entry.
+ (setq buffer (get-buffer-create (format " *diff-syntax:%s.~%s~*"
+ file revision)))
+ (condition-case nil
+ (vc-find-revision-no-save file revision diff-vc-backend buffer)
+ (error
+ (kill-buffer buffer)
+ (setq buffer nil))
+ (:success
+ (push (cons file-rev buffer)
+ diff--cached-revision-buffers))))
+ (when diff--cache-clean-timer
+ (cancel-timer diff--cache-clean-timer))
+ (diff--cache-schedule-clean)
+ (and buffer
+ (with-current-buffer buffer
+ (diff-syntax-fontify-props file text line-nb)))))
+
(defun diff-syntax-fontify-hunk (beg end old)
"Highlight source language syntax in diff hunk between BEG and END.
When OLD is non-nil, highlight the hunk from the old source."
@@ -2867,22 +2964,8 @@ When OLD is non-nil, highlight the hunk from the old
source."
(insert-file-contents file)
(setq diff--syntax-file-attributes attrs)))
(diff-syntax-fontify-props file text line-nb)))))
- ;; Get properties from a cached revision
- (let* ((buffer-name (format " *diff-syntax:%s.~%s~*"
- file revision))
- (buffer (get-buffer buffer-name)))
- (if buffer
- ;; Don't re-initialize the buffer (which would throw
- ;; away the previous fontification work).
- (setq file nil)
- (setq buffer (ignore-errors
- (vc-find-revision-no-save
- file revision
- diff-vc-backend
- (get-buffer-create buffer-name)))))
- (when buffer
- (with-current-buffer buffer
- (diff-syntax-fontify-props file text line-nb))))))))
+ (diff--get-revision-properties file revision
+ text line-nb)))))
(let ((file (car (diff-hunk-file-names old))))
(cond
((and file diff-default-directory
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 456417e566e..18b4a8691e9 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -1411,9 +1411,16 @@ This prompts for a branch to merge from."
(vc-message-unresolved-conflicts buffer-file-name)))
(defun vc-git-clone (remote directory rev)
- (if rev
- (vc-git--out-ok "clone" "--branch" rev remote directory)
+ "Attempt to clone REMOTE repository into DIRECTORY at revision REV."
+ (cond
+ ((null rev)
(vc-git--out-ok "clone" remote directory))
+ ((ignore-errors
+ (vc-git--out-ok "clone" "--branch" rev remote directory)))
+ ((vc-git--out-ok "clone" remote directory)
+ (let ((default-directory directory))
+ (vc-git--out-ok "checkout" rev)))
+ ((error "Failed to check out %s at %s" remote rev)))
directory)
;;; HISTORY FUNCTIONS
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el
index 1493845e2d9..75f68dd80d1 100644
--- a/lisp/vc/vc-hooks.el
+++ b/lisp/vc/vc-hooks.el
@@ -186,7 +186,8 @@ revision number and lock status."
This minor mode is automatically activated whenever you visit a file under
control of one of the revision control systems in `vc-handled-backends'.
VC commands are globally reachable under the prefix \\[vc-prefix-map]:
-\\{vc-prefix-map}")
+\\{vc-prefix-map}"
+ nil)
(defmacro vc-error-occurred (&rest body)
`(condition-case nil (progn ,@body nil) (error t)))
@@ -197,7 +198,7 @@ VC commands are globally reachable under the prefix
\\[vc-prefix-map]:
;; during any subsequent VC operations, and forget them when
;; the buffer is killed.
-(defvar vc-file-prop-obarray (make-vector 17 0)
+(defvar vc-file-prop-obarray (obarray-make 17)
"Obarray for per-file properties.")
(defvar vc-touched-properties nil)
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index f612daaa569..3cd17276fa4 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -935,7 +935,7 @@ is sensitive to blank lines."
(defun vc-clear-context ()
"Clear all cached file properties."
(interactive)
- (fillarray vc-file-prop-obarray 0))
+ (obarray-clear vc-file-prop-obarray))
(defmacro with-vc-properties (files form settings)
"Execute FORM, then maybe set per-file properties for FILES.
@@ -3623,7 +3623,15 @@ revisions.
When invoked interactively in a Log View buffer with
marked revisions, use those."
(interactive
- (let ((revs (vc-prepare-patch-prompt-revisions)) to)
+ (let* ((revs (vc-prepare-patch-prompt-revisions))
+ (subject
+ (and (length= revs 1)
+ (plist-get
+ (vc-call-backend
+ (vc-responsible-backend default-directory)
+ 'prepare-patch (car revs))
+ :subject)))
+ to)
(require 'message)
(while (null (setq to (completing-read-multiple
(format-prompt
@@ -3636,10 +3644,9 @@ marked revisions, use those."
(sit-for blink-matching-delay))
(list (string-join to ", ")
(and (not vc-prepare-patches-separately)
- (read-string "Subject: " "[PATCH] " nil nil t))
+ (read-string "Subject: " (or subject "[PATCH] ") nil nil t))
revs)))
(save-current-buffer
- (vc-ensure-vc-buffer)
(let ((patches (mapcar (lambda (rev)
(vc-call-backend
(vc-responsible-backend default-directory)
diff --git a/lisp/vcursor.el b/lisp/vcursor.el
index ec5adbd832c..15791285b13 100644
--- a/lisp/vcursor.el
+++ b/lisp/vcursor.el
@@ -433,7 +433,7 @@ Default is nil."
(defcustom vcursor-interpret-input nil
"If non-nil, input from the vcursor is treated as interactive input.
This will cause text insertion to be much slower. Note that no special
-interpretation of strings is done: \"\C-x\" is a string of four
+interpretation of strings is done: \"\\C-x\" is a string of four
characters. The default is simply to copy strings."
:type 'boolean
:version "20.3")
diff --git a/lisp/visual-wrap.el b/lisp/visual-wrap.el
index 20e55444082..d95cf4bb569 100644
--- a/lisp/visual-wrap.el
+++ b/lisp/visual-wrap.el
@@ -173,7 +173,9 @@ by `visual-wrap-extra-indent'."
;;;###autoload
(define-minor-mode visual-wrap-prefix-mode
- "Display continuation lines with prefixes from surrounding context."
+ "Display continuation lines with prefixes from surrounding context.
+To enable this minor mode across all buffers, enable
+`global-visual-wrap-prefix-mode'."
:lighter ""
:group 'visual-line
(if visual-wrap-prefix-mode
@@ -192,5 +194,11 @@ by `visual-wrap-extra-indent'."
(widen)
(remove-text-properties (point-min) (point-max) '(wrap-prefix nil))))))
+;;;###autoload
+(define-globalized-minor-mode global-visual-wrap-prefix-mode
+ visual-wrap-prefix-mode visual-wrap-prefix-mode
+ :init-value nil
+ :group 'visual-line)
+
(provide 'visual-wrap)
;;; visual-wrap.el ends here
diff --git a/lisp/winner.el b/lisp/winner.el
index 2aa59a86b25..19641a05bfc 100644
--- a/lisp/winner.el
+++ b/lisp/winner.el
@@ -178,7 +178,8 @@ You may want to include buffer names such as *Help*,
*Apropos*,
(setq winner-last-frames nil)
(setq winner-last-command this-command))
(dolist (frame winner-modified-list)
- (winner-insert-if-new frame))
+ (if (frame-live-p frame)
+ (winner-insert-if-new frame)))
(setq winner-modified-list nil)
(winner-remember)))
diff --git a/lisp/woman.el b/lisp/woman.el
index a9af46fa387..2357ba6b132 100644
--- a/lisp/woman.el
+++ b/lisp/woman.el
@@ -2566,7 +2566,8 @@ If DELETE is non-nil then delete from point."
;; "\\(\\\\{\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[ \t]*"
;; Interpret bogus `el \}' as `el \{',
;; especially for Tcl/Tk man pages:
- "\\(\\\\{\\|el[ \t]*\\\\}\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[
\t]*")
+ "\\(\\\\{\\|el[ \t]*\\\\}\\)\\|\\(\n[.']\\)?[ \t]*\\\\}[
\t]*"
+ nil t)
(match-beginning 1))
(re-search-forward "\\\\}"))
(delete-region (if delete from (match-beginning 0)) (point))
diff --git a/m4/copy-file-range.m4 b/m4/copy-file-range.m4
index e9198549510..443e598ba55 100644
--- a/m4/copy-file-range.m4
+++ b/m4/copy-file-range.m4
@@ -1,4 +1,4 @@
-# copy-file-range.m4
+# copy-file-range.m4 serial 5
dnl Copyright 2019-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -17,22 +17,33 @@ AC_DEFUN([gl_FUNC_COPY_FILE_RANGE],
dnl Programs that use copy_file_range must fall back on read+write
dnl anyway, and there's little point to substituting the Gnulib stub
dnl for a glibc stub.
- AC_CACHE_CHECK([for copy_file_range], [gl_cv_func_copy_file_range],
- [AC_LINK_IFELSE(
- [AC_LANG_PROGRAM(
- [[#include <unistd.h>
- ]],
- [[ssize_t (*func) (int, off_t *, int, off_t *, size_t, unsigned)
- = copy_file_range;
- return func (0, 0, 0, 0, 0, 0) & 127;
- ]])
- ],
- [gl_cv_func_copy_file_range=yes],
- [gl_cv_func_copy_file_range=no])
- ])
-
+ case "$host_os" in
+ *-gnu* | gnu*)
+ AC_CACHE_CHECK([for copy_file_range], [gl_cv_func_copy_file_range],
+ [AC_LINK_IFELSE(
+ [AC_LANG_PROGRAM(
+ [[#include <unistd.h>
+ ]],
+ [[ssize_t (*func) (int, off_t *, int, off_t *, size_t, unsigned)
+ = copy_file_range;
+ return func (0, 0, 0, 0, 0, 0) & 127;
+ ]])
+ ],
+ [gl_cv_func_copy_file_range=yes],
+ [gl_cv_func_copy_file_range=no])
+ ])
+ gl_cv_onwards_func_copy_file_range="$gl_cv_func_copy_file_range"
+ ;;
+ *)
+ gl_CHECK_FUNCS_ANDROID([copy_file_range], [[#include <unistd.h>]])
+ gl_cv_func_copy_file_range="$ac_cv_func_copy_file_range"
+ ;;
+ esac
if test "$gl_cv_func_copy_file_range" != yes; then
HAVE_COPY_FILE_RANGE=0
+ case "$gl_cv_onwards_func_copy_file_range" in
+ future*) REPLACE_COPY_FILE_RANGE=1 ;;
+ esac
else
AC_DEFINE([HAVE_COPY_FILE_RANGE], 1,
[Define to 1 if the function copy_file_range exists.])
diff --git a/m4/gettime.m4 b/m4/gettime.m4
index e450e6b9d05..1ec018d5154 100644
--- a/m4/gettime.m4
+++ b/m4/gettime.m4
@@ -1,4 +1,4 @@
-# gettime.m4 serial 14
+# gettime.m4 serial 15
dnl Copyright (C) 2002, 2004-2006, 2009-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -64,5 +64,5 @@ AC_DEFUN([gl_GETTIME_RES],
dnl Prerequisites of lib/gettime-res.c.
AC_REQUIRE([gl_CLOCK_TIME])
AC_REQUIRE([gl_TIMESPEC])
- AC_CHECK_FUNCS_ONCE([timespec_getres])
+ gl_CHECK_FUNCS_ANDROID([timespec_getres], [[#include <time.h>]])
])
diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4
index 03d10fa51ea..d8d0904f787 100644
--- a/m4/gnulib-common.m4
+++ b/m4/gnulib-common.m4
@@ -1,4 +1,4 @@
-# gnulib-common.m4 serial 90
+# gnulib-common.m4 serial 92
dnl Copyright (C) 2007-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -76,42 +76,48 @@ AC_DEFUN([gl_COMMON_BODY], [
#endif])
AH_VERBATIM([attribute],
[/* Attributes. */
-#if (defined __has_attribute \
- && (!defined __clang_minor__ \
- || (defined __apple_build_version__ \
- ? 6000000 <= __apple_build_version__ \
- : 5 <= __clang_major__)))
-# define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__)
-#else
-# define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr
-# define _GL_ATTR_alloc_size _GL_GNUC_PREREQ (4, 3)
-# define _GL_ATTR_always_inline _GL_GNUC_PREREQ (3, 2)
-# define _GL_ATTR_artificial _GL_GNUC_PREREQ (4, 3)
-# define _GL_ATTR_cold _GL_GNUC_PREREQ (4, 3)
-# define _GL_ATTR_const _GL_GNUC_PREREQ (2, 95)
-# define _GL_ATTR_deprecated _GL_GNUC_PREREQ (3, 1)
-# define _GL_ATTR_diagnose_if 0
-# define _GL_ATTR_error _GL_GNUC_PREREQ (4, 3)
-# define _GL_ATTR_externally_visible _GL_GNUC_PREREQ (4, 1)
-# define _GL_ATTR_fallthrough _GL_GNUC_PREREQ (7, 0)
-# define _GL_ATTR_format _GL_GNUC_PREREQ (2, 7)
-# define _GL_ATTR_leaf _GL_GNUC_PREREQ (4, 6)
-# define _GL_ATTR_malloc _GL_GNUC_PREREQ (3, 0)
-# ifdef _ICC
-# define _GL_ATTR_may_alias 0
+/* Define _GL_HAS_ATTRIBUTE only once, because on FreeBSD, with gcc < 5, if
+ <config.h> gets included once again after <sys/cdefs.h>, __has_attribute(x)
+ expands to 0 always, and redefining _GL_HAS_ATTRIBUTE would turn off all
+ attributes. */
+#ifndef _GL_HAS_ATTRIBUTE
+# if (defined __has_attribute \
+ && (!defined __clang_minor__ \
+ || (defined __apple_build_version__ \
+ ? 7000000 <= __apple_build_version__ \
+ : 5 <= __clang_major__)))
+# define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__)
# else
-# define _GL_ATTR_may_alias _GL_GNUC_PREREQ (3, 3)
+# define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr
+# define _GL_ATTR_alloc_size _GL_GNUC_PREREQ (4, 3)
+# define _GL_ATTR_always_inline _GL_GNUC_PREREQ (3, 2)
+# define _GL_ATTR_artificial _GL_GNUC_PREREQ (4, 3)
+# define _GL_ATTR_cold _GL_GNUC_PREREQ (4, 3)
+# define _GL_ATTR_const _GL_GNUC_PREREQ (2, 95)
+# define _GL_ATTR_deprecated _GL_GNUC_PREREQ (3, 1)
+# define _GL_ATTR_diagnose_if 0
+# define _GL_ATTR_error _GL_GNUC_PREREQ (4, 3)
+# define _GL_ATTR_externally_visible _GL_GNUC_PREREQ (4, 1)
+# define _GL_ATTR_fallthrough _GL_GNUC_PREREQ (7, 0)
+# define _GL_ATTR_format _GL_GNUC_PREREQ (2, 7)
+# define _GL_ATTR_leaf _GL_GNUC_PREREQ (4, 6)
+# define _GL_ATTR_malloc _GL_GNUC_PREREQ (3, 0)
+# ifdef _ICC
+# define _GL_ATTR_may_alias 0
+# else
+# define _GL_ATTR_may_alias _GL_GNUC_PREREQ (3, 3)
+# endif
+# define _GL_ATTR_noinline _GL_GNUC_PREREQ (3, 1)
+# define _GL_ATTR_nonnull _GL_GNUC_PREREQ (3, 3)
+# define _GL_ATTR_nonstring _GL_GNUC_PREREQ (8, 0)
+# define _GL_ATTR_nothrow _GL_GNUC_PREREQ (3, 3)
+# define _GL_ATTR_packed _GL_GNUC_PREREQ (2, 7)
+# define _GL_ATTR_pure _GL_GNUC_PREREQ (2, 96)
+# define _GL_ATTR_returns_nonnull _GL_GNUC_PREREQ (4, 9)
+# define _GL_ATTR_sentinel _GL_GNUC_PREREQ (4, 0)
+# define _GL_ATTR_unused _GL_GNUC_PREREQ (2, 7)
+# define _GL_ATTR_warn_unused_result _GL_GNUC_PREREQ (3, 4)
# endif
-# define _GL_ATTR_noinline _GL_GNUC_PREREQ (3, 1)
-# define _GL_ATTR_nonnull _GL_GNUC_PREREQ (3, 3)
-# define _GL_ATTR_nonstring _GL_GNUC_PREREQ (8, 0)
-# define _GL_ATTR_nothrow _GL_GNUC_PREREQ (3, 3)
-# define _GL_ATTR_packed _GL_GNUC_PREREQ (2, 7)
-# define _GL_ATTR_pure _GL_GNUC_PREREQ (2, 96)
-# define _GL_ATTR_returns_nonnull _GL_GNUC_PREREQ (4, 9)
-# define _GL_ATTR_sentinel _GL_GNUC_PREREQ (4, 0)
-# define _GL_ATTR_unused _GL_GNUC_PREREQ (2, 7)
-# define _GL_ATTR_warn_unused_result _GL_GNUC_PREREQ (3, 4)
#endif
/* Use __has_c_attribute if available. However, do not use with
diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4
index 2e5b328e3d8..d8b92e7b122 100644
--- a/m4/gnulib-comp.m4
+++ b/m4/gnulib-comp.m4
@@ -432,7 +432,8 @@ AC_DEFUN([gl_INIT],
])
gl_STRING_MODULE_INDICATOR([memrchr])
gl_FUNC_MEMSET_EXPLICIT
- gl_CONDITIONAL([GL_COND_OBJ_MEMSET_EXPLICIT], [test $HAVE_MEMSET_EXPLICIT =
0])
+ gl_CONDITIONAL([GL_COND_OBJ_MEMSET_EXPLICIT],
+ [test $HAVE_MEMSET_EXPLICIT = 0 || test
$REPLACE_MEMSET_EXPLICIT = 1])
AM_COND_IF([GL_COND_OBJ_MEMSET_EXPLICIT], [
gl_PREREQ_MEMSET_EXPLICIT
])
@@ -1023,7 +1024,7 @@ AC_DEFUN([gl_INIT],
if test $ac_use_included_regex = yes; then
func_gl_gnulib_m4code_fd38c7e463b54744b77b98aeafb4fa7c
fi
- if { test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test
$ac_cv_type_long_long_int = yes; then
+ if test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; then
func_gl_gnulib_m4code_strtoll
fi
if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then
@@ -1421,6 +1422,7 @@ AC_DEFUN([gl_FILE_LIST], [
lib/stdlib.in.h
lib/stpcpy.c
lib/str-two-way.h
+ lib/strftime.c
lib/strftime.h
lib/string.in.h
lib/strnlen.c
diff --git a/m4/memset_explicit.m4 b/m4/memset_explicit.m4
index 6ac798d4557..19514ff917e 100644
--- a/m4/memset_explicit.m4
+++ b/m4/memset_explicit.m4
@@ -1,3 +1,4 @@
+# memset_explicit.m4 serial 2
dnl Copyright 2022-2024 Free Software Foundation, Inc.
dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
@@ -7,9 +8,12 @@ AC_DEFUN([gl_FUNC_MEMSET_EXPLICIT],
[
AC_REQUIRE([gl_STRING_H_DEFAULTS])
- AC_CHECK_FUNCS_ONCE([memset_explicit])
+ gl_CHECK_FUNCS_ANDROID([memset_explicit], [[#include <string.h>]])
if test $ac_cv_func_memset_explicit = no; then
HAVE_MEMSET_EXPLICIT=0
+ case "$gl_cv_onwards_func_memset_explicit" in
+ future*) REPLACE_MEMSET_EXPLICIT=1 ;;
+ esac
fi
])
diff --git a/m4/nanosleep.m4 b/m4/nanosleep.m4
index c51f590402f..ff730b676cd 100644
--- a/m4/nanosleep.m4
+++ b/m4/nanosleep.m4
@@ -1,4 +1,4 @@
-# serial 46
+# serial 47
dnl From Jim Meyering.
dnl Check for the nanosleep function.
@@ -119,6 +119,10 @@ AC_DEFUN([gl_FUNC_NANOSLEEP],
# Guess it halfway works when the kernel is Linux.
linux*)
gl_cv_func_nanosleep='guessing no (mishandles large arguments)' ;;
+ # Midipix generally emulates the Linux system calls,
+ # but here it handles large arguments correctly.
+ midipix*)
+ gl_cv_func_nanosleep='guessing yes' ;;
# Guess no on native Windows.
mingw* | windows*)
gl_cv_func_nanosleep='guessing no' ;;
diff --git a/m4/nstrftime.m4 b/m4/nstrftime.m4
index 67250dc9455..aa5d63a54b5 100644
--- a/m4/nstrftime.m4
+++ b/m4/nstrftime.m4
@@ -1,4 +1,4 @@
-# serial 37
+# serial 38
# Copyright (C) 1996-1997, 1999-2007, 2009-2024 Free Software Foundation, Inc.
#
@@ -16,7 +16,4 @@ AC_DEFUN([gl_FUNC_GNU_STRFTIME],
AC_REQUIRE([AC_STRUCT_TIMEZONE])
AC_REQUIRE([gl_TM_GMTOFF])
-
- AC_DEFINE([my_strftime], [nstrftime],
- [Define to the name of the strftime replacement function.])
])
diff --git a/m4/string_h.m4 b/m4/string_h.m4
index 8b12101447f..9ea748cc774 100644
--- a/m4/string_h.m4
+++ b/m4/string_h.m4
@@ -5,7 +5,7 @@
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
-# serial 38
+# serial 39
# Written by Paul Eggert.
@@ -132,6 +132,7 @@ AC_DEFUN([gl_STRING_H_DEFAULTS],
REPLACE_MEMCHR=0; AC_SUBST([REPLACE_MEMCHR])
REPLACE_MEMMEM=0; AC_SUBST([REPLACE_MEMMEM])
REPLACE_MEMPCPY=0; AC_SUBST([REPLACE_MEMPCPY])
+ REPLACE_MEMSET_EXPLICIT=0; AC_SUBST([REPLACE_MEMSET_EXPLICIT])
REPLACE_STPCPY=0; AC_SUBST([REPLACE_STPCPY])
REPLACE_STPNCPY=0; AC_SUBST([REPLACE_STPNCPY])
REPLACE_STRCHRNUL=0; AC_SUBST([REPLACE_STRCHRNUL])
diff --git a/m4/time_h.m4 b/m4/time_h.m4
index 367f69efae6..32fade0f401 100644
--- a/m4/time_h.m4
+++ b/m4/time_h.m4
@@ -2,7 +2,7 @@
# Copyright (C) 2000-2001, 2003-2007, 2009-2024 Free Software Foundation, Inc.
-# serial 24
+# serial 25
# This file is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
@@ -175,5 +175,6 @@ AC_DEFUN([gl_TIME_H_DEFAULTS],
REPLACE_TIME=0; AC_SUBST([REPLACE_TIME])
REPLACE_TIMEGM=0; AC_SUBST([REPLACE_TIMEGM])
REPLACE_TIMESPEC_GET=0; AC_SUBST([REPLACE_TIMESPEC_GET])
+ REPLACE_TIMESPEC_GETRES=0; AC_SUBST([REPLACE_TIMESPEC_GETRES])
REPLACE_TZSET=0; AC_SUBST([REPLACE_TZSET])
])
diff --git a/m4/utimens.m4 b/m4/utimens.m4
index af03e6b52be..0f5bfd4c843 100644
--- a/m4/utimens.m4
+++ b/m4/utimens.m4
@@ -3,7 +3,7 @@ dnl This file is free software; the Free Software Foundation
dnl gives unlimited permission to copy and/or distribute it,
dnl with or without modifications, as long as this notice is preserved.
-dnl serial 15
+dnl serial 16
AC_DEFUN([gl_UTIMENS],
[
@@ -36,12 +36,13 @@ AC_DEFUN([gl_UTIMENS],
[gl_cv_func_futimesat_works=yes],
[gl_cv_func_futimesat_works=no],
[case "$host_os" in
- # Guess yes on Linux systems.
- linux-* | linux) gl_cv_func_futimesat_works="guessing yes" ;;
- # Guess yes on glibc systems.
- *-gnu*) gl_cv_func_futimesat_works="guessing yes" ;;
- # If we don't know, obey --enable-cross-guesses.
- *)
gl_cv_func_futimesat_works="$gl_cross_guess_normal" ;;
+ # Guess yes on Linux systems
+ # and on systems that emulate the Linux system
calls.
+ linux* | midipix*) gl_cv_func_futimesat_works="guessing yes" ;;
+ # Guess yes on glibc systems.
+ *-gnu*) gl_cv_func_futimesat_works="guessing yes" ;;
+ # If we don't know, obey --enable-cross-guesses.
+ *)
gl_cv_func_futimesat_works="$gl_cross_guess_normal" ;;
esac
])
rm -f conftest.file])
diff --git a/m4/utimensat.m4 b/m4/utimensat.m4
index e595b333d17..4af7f6f81c8 100644
--- a/m4/utimensat.m4
+++ b/m4/utimensat.m4
@@ -1,4 +1,4 @@
-# serial 11
+# serial 12
# See if we need to provide utimensat replacement.
dnl Copyright (C) 2009-2024 Free Software Foundation, Inc.
@@ -83,6 +83,9 @@ AC_DEFUN([gl_FUNC_UTIMENSAT],
# Guess yes on Linux or glibc systems.
linux-* | linux | *-gnu* | gnu*)
gl_cv_func_utimensat_works="guessing yes" ;;
+ # Guess yes on systems that emulate the Linux system calls.
+ midipix*)
+ gl_cv_func_utimensat_works="guessing yes" ;;
# Guess 'nearly' on AIX.
aix*)
gl_cv_func_utimensat_works="guessing nearly" ;;
diff --git a/nt/cmdproxy.c b/nt/cmdproxy.c
index 0500b653bb2..c012151cf96 100644
--- a/nt/cmdproxy.c
+++ b/nt/cmdproxy.c
@@ -38,6 +38,14 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <string.h> /* strlen */
#include <ctype.h> /* isspace, isalpha */
+/* UCRT has a C99-compatible snprintf, and _snprintf is defined inline
+ in stdio.h, which we don't want to include here. Since the
+ differences in behavior between snprintf and _snprintf don't matter
+ in this file, we take the easy way out. */
+#ifdef _UCRT
+# define _snprintf snprintf
+#endif
+
/* We don't want to include stdio.h because we are already duplicating
lots of it here */
extern int _snprintf (char *buffer, size_t count, const char *format, ...);
diff --git a/nt/gnulib-cfg.mk b/nt/gnulib-cfg.mk
index 5b1c2c88ba5..048f812724a 100644
--- a/nt/gnulib-cfg.mk
+++ b/nt/gnulib-cfg.mk
@@ -46,6 +46,7 @@ OMIT_GNULIB_MODULE_allocator = true
OMIT_GNULIB_MODULE_at-internal = true
OMIT_GNULIB_MODULE_canonicalize-lgpl = true
OMIT_GNULIB_MODULE_careadlinkat = true
+OMIT_GNULIB_MODULE_copy-file-range = true
OMIT_GNULIB_MODULE_dirent = true
OMIT_GNULIB_MODULE_dirfd = true
OMIT_GNULIB_MODULE_fchmodat = true
diff --git a/src/alloc.c b/src/alloc.c
index 15bb65cf74f..16257469aa6 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -360,13 +360,13 @@ static struct gcstat
object_ct total_intervals, total_free_intervals;
object_ct total_buffers;
- /* Size of the ancillary arrays of live hash-table objects.
+ /* Size of the ancillary arrays of live hash-table and obarray objects.
The objects themselves are not included (counted as vectors above). */
byte_ct total_hash_table_bytes;
} gcstat;
-/* Total size of ancillary arrays of all allocated hash-table objects,
- both dead and alive. This number is always kept up-to-date. */
+/* Total size of ancillary arrays of all allocated hash-table and obarray
+ objects, both dead and alive. This number is always kept up-to-date. */
static ptrdiff_t hash_table_allocated_bytes = 0;
/* Points to memory space allocated as "spare", to be freed if we run
@@ -3443,7 +3443,7 @@ cleanup_vector (struct Lisp_Vector *vector)
struct Lisp_Hash_Table *h = PSEUDOVEC_STRUCT (vector, Lisp_Hash_Table);
if (h->table_size > 0)
{
- eassert (h->index_size > 1);
+ eassert (h->index_bits > 0);
xfree (h->index);
xfree (h->key_and_value);
xfree (h->next);
@@ -3451,10 +3451,19 @@ cleanup_vector (struct Lisp_Vector *vector)
ptrdiff_t bytes = (h->table_size * (2 * sizeof *h->key_and_value
+ sizeof *h->hash
+ sizeof *h->next)
- + h->index_size * sizeof *h->index);
+ + hash_table_index_size (h) * sizeof *h->index);
hash_table_allocated_bytes -= bytes;
}
}
+ break;
+ case PVEC_OBARRAY:
+ {
+ struct Lisp_Obarray *o = PSEUDOVEC_STRUCT (vector, Lisp_Obarray);
+ xfree (o->buckets);
+ ptrdiff_t bytes = obarray_size (o) * sizeof *o->buckets;
+ hash_table_allocated_bytes -= bytes;
+ }
+ break;
/* Keep the switch exhaustive. */
case PVEC_NORMAL_VECTOR:
case PVEC_FREE:
@@ -3951,7 +3960,7 @@ Its value is void, and its function definition and
property list are nil. */)
if (symbol_free_list)
{
ASAN_UNPOISON_SYMBOL (symbol_free_list);
- XSETSYMBOL (val, symbol_free_list);
+ val = make_lisp_symbol (symbol_free_list);
symbol_free_list = symbol_free_list->u.s.next;
}
else
@@ -3967,7 +3976,7 @@ Its value is void, and its function definition and
property list are nil. */)
}
ASAN_UNPOISON_SYMBOL (&symbol_block->symbols[symbol_block_index]);
- XSETSYMBOL (val, &symbol_block->symbols[symbol_block_index]);
+ val = make_lisp_symbol (&symbol_block->symbols[symbol_block_index]);
symbol_block_index++;
}
@@ -5632,7 +5641,8 @@ valid_lisp_object_p (Lisp_Object obj)
return 0;
}
-/* Like xmalloc, but makes allocation count toward the total consing.
+/* Like xmalloc, but makes allocation count toward the total consing
+ and hash table or obarray usage.
Return NULL for a zero-sized allocation. */
void *
hash_table_alloc_bytes (ptrdiff_t nbytes)
@@ -5959,7 +5969,8 @@ purecopy_hash_table (struct Lisp_Hash_Table *table)
for (ptrdiff_t i = 0; i < nvalues; i++)
pure->key_and_value[i] = purecopy (table->key_and_value[i]);
- ptrdiff_t index_bytes = table->index_size * sizeof *table->index;
+ ptrdiff_t index_bytes = hash_table_index_size (table)
+ * sizeof *table->index;
pure->index = pure_alloc (index_bytes, -(int)sizeof *table->index);
memcpy (pure->index, table->index, index_bytes);
}
@@ -6033,8 +6044,7 @@ purecopy (Lisp_Object obj)
return obj; /* Don't hash cons it. */
}
- struct Lisp_Hash_Table *h = purecopy_hash_table (table);
- XSET_HASH_TABLE (obj, h);
+ obj = make_lisp_hash_table (purecopy_hash_table (table));
}
else if (COMPILEDP (obj) || VECTORP (obj) || RECORDP (obj))
{
@@ -7310,6 +7320,14 @@ process_mark_stack (ptrdiff_t base_sp)
break;
}
+ case PVEC_OBARRAY:
+ {
+ struct Lisp_Obarray *o = (struct Lisp_Obarray *)ptr;
+ set_vector_marked (ptr);
+ mark_stack_push_values (o->buckets, obarray_size (o));
+ break;
+ }
+
case PVEC_CHAR_TABLE:
case PVEC_SUB_CHAR_TABLE:
mark_char_table (ptr, (enum pvec_type) pvectype);
@@ -7380,12 +7398,8 @@ process_mark_stack (ptrdiff_t base_sp)
mark_stack_push_value (SYMBOL_VAL (ptr));
break;
case SYMBOL_VARALIAS:
- {
- Lisp_Object tem;
- XSETSYMBOL (tem, SYMBOL_ALIAS (ptr));
- mark_stack_push_value (tem);
- break;
- }
+ mark_stack_push_value (make_lisp_symbol (SYMBOL_ALIAS (ptr)));
+ break;
case SYMBOL_LOCALIZED:
{
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (ptr);
diff --git a/src/android.c b/src/android.c
index 4a74f5b2af4..41481afa475 100644
--- a/src/android.c
+++ b/src/android.c
@@ -40,6 +40,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <sys/param.h>
#include <sys/stat.h>
+#include <sys/select.h>
/* Old NDK versions lack MIN and MAX. */
#include <minmax.h>
@@ -112,6 +113,8 @@ struct android_emacs_window
jmethodID define_cursor;
jmethodID damage_rect;
jmethodID recreate_activity;
+ jmethodID clear_window;
+ jmethodID clear_area;
};
struct android_emacs_cursor
@@ -152,6 +155,13 @@ static char *android_files_dir;
/* The Java environment being used for the main thread. */
JNIEnv *android_java_env;
+#ifdef THREADS_ENABLED
+
+/* The Java VM new threads attach to. */
+JavaVM *android_jvm;
+
+#endif /* THREADS_ENABLED */
+
/* The EmacsGC class. */
static jclass emacs_gc_class;
@@ -496,6 +506,9 @@ android_handle_sigusr1 (int sig, siginfo_t *siginfo, void
*arg)
This should ideally be defined further down. */
static sem_t android_query_sem;
+/* ID of the Emacs thread. */
+static pthread_t main_thread_id;
+
/* Set up the global event queue by initializing the mutex and two
condition variables, and the linked list of events. This must be
called before starting the Emacs thread. Also, initialize the
@@ -531,6 +544,8 @@ android_init_events (void)
event_queue.events.next = &event_queue.events;
event_queue.events.last = &event_queue.events;
+ main_thread_id = pthread_self ();
+
#if __ANDROID_API__ >= 16
/* Before starting the select thread, make sure the disposition for
@@ -579,10 +594,6 @@ android_pending (void)
return i;
}
-/* Forward declaration. */
-
-static void android_check_query (void);
-
/* Wait for events to become available synchronously. Return once an
event arrives. Also, reply to the UI thread whenever it requires a
response. */
@@ -732,6 +743,12 @@ android_select (int nfds, fd_set *readfds, fd_set
*writefds,
static char byte;
#endif
+#ifdef THREADS_ENABLED
+ if (!pthread_equal (pthread_self (), main_thread_id))
+ return pselect (nfds, readfds, writefds, exceptfds, timeout,
+ NULL);
+#endif /* THREADS_ENABLED */
+
/* Since Emacs is reading keyboard input again, signify that queries
from input methods are no longer ``urgent''. */
@@ -837,9 +854,11 @@ android_select (int nfds, fd_set *readfds, fd_set
*writefds,
if (nfds_return < 0)
errno = EINTR;
+#ifndef THREADS_ENABLED
/* Now check for and run anything the UI thread wants to run in the
main thread. */
android_check_query ();
+#endif /* THREADS_ENABLED */
return nfds_return;
}
@@ -1315,12 +1334,17 @@ NATIVE_NAME (setEmacsParams) (JNIEnv *env, jobject
object,
const char *java_string;
struct stat statb;
+#ifdef THREADS_ENABLED
+ /* Save the Java VM. */
+ if ((*env)->GetJavaVM (env, &android_jvm))
+ emacs_abort ();
+#endif /* THREADS_ENABLED */
+
/* Set the Android API level early, as it is used by
`android_vfs_init'. */
android_api_level = api_level;
/* This function should only be called from the main thread. */
-
android_pixel_density_x = pixel_density_x;
android_pixel_density_y = pixel_density_y;
android_scaled_pixel_density = scaled_density;
@@ -1583,16 +1607,13 @@ android_init_emacs_service (void)
FIND_METHOD (draw_point, "drawPoint",
"(Lorg/gnu/emacs/EmacsDrawable;"
"Lorg/gnu/emacs/EmacsGC;II)V");
- FIND_METHOD (clear_window, "clearWindow",
- "(Lorg/gnu/emacs/EmacsWindow;)V");
- FIND_METHOD (clear_area, "clearArea",
- "(Lorg/gnu/emacs/EmacsWindow;IIII)V");
FIND_METHOD (ring_bell, "ringBell", "(I)V");
FIND_METHOD (query_tree, "queryTree",
"(Lorg/gnu/emacs/EmacsWindow;)[S");
FIND_METHOD (get_screen_width, "getScreenWidth", "(Z)I");
FIND_METHOD (get_screen_height, "getScreenHeight", "(Z)I");
FIND_METHOD (detect_mouse, "detectMouse", "()Z");
+ FIND_METHOD (detect_keyboard, "detectKeyboard", "()Z");
FIND_METHOD (name_keysym, "nameKeysym", "(I)Ljava/lang/String;");
FIND_METHOD (browse_url, "browseUrl", "(Ljava/lang/String;Z)"
"Ljava/lang/String;");
@@ -1809,6 +1830,8 @@ android_init_emacs_window (void)
android_damage_window. */
FIND_METHOD (damage_rect, "damageRect", "(IIII)V");
FIND_METHOD (recreate_activity, "recreateActivity", "()V");
+ FIND_METHOD (clear_window, "clearWindow", "()V");
+ FIND_METHOD (clear_area, "clearArea", "(IIII)V");
#undef FIND_METHOD
}
@@ -2496,6 +2519,8 @@ JNIEXPORT jboolean JNICALL
NATIVE_NAME (shouldForwardMultimediaButtons) (JNIEnv *env,
jobject object)
{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
/* Yes, android_pass_multimedia_buttons_to_system is being
read from the UI thread. */
return !android_pass_multimedia_buttons_to_system;
@@ -2504,6 +2529,8 @@ NATIVE_NAME (shouldForwardMultimediaButtons) (JNIEnv *env,
JNIEXPORT jboolean JNICALL
NATIVE_NAME (shouldForwardCtrlSpace) (JNIEnv *env, jobject object)
{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
return !android_intercept_control_space;
}
@@ -2607,6 +2634,8 @@ JNIEXPORT void JNICALL
NATIVE_NAME (notifyPixelsChanged) (JNIEnv *env, jobject object,
jobject bitmap)
{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
void *data;
/* Lock and unlock the bitmap. This calls
@@ -2660,6 +2689,8 @@ NATIVE_NAME (answerQuerySpin) (JNIEnv *env, jobject
object)
JNIEXPORT void JNICALL
NATIVE_NAME (setupSystemThread) (void)
{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
sigset_t sigset;
/* Block everything except for SIGSEGV and SIGBUS; those two are
@@ -3408,10 +3439,9 @@ android_clear_window (android_window handle)
window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
(*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
- emacs_service,
- service_class.class,
- service_class.clear_window,
- window);
+ window,
+ window_class.class,
+ window_class.clear_window);
android_exception_check ();
}
@@ -4722,10 +4752,10 @@ android_clear_area (android_window handle, int x, int y,
window = android_resolve_handle (handle, ANDROID_HANDLE_WINDOW);
(*android_java_env)->CallNonvirtualVoidMethod (android_java_env,
- emacs_service,
- service_class.class,
- service_class.clear_area,
- window, (jint) x, (jint) y,
+ window,
+ window_class.class,
+ window_class.clear_area,
+ (jint) x, (jint) y,
(jint) width, (jint) height);
}
@@ -5626,6 +5656,21 @@ android_detect_mouse (void)
return rc;
}
+bool
+android_detect_keyboard (void)
+{
+ bool rc;
+ jmethodID method;
+
+ method = service_class.detect_keyboard;
+ rc = (*android_java_env)->CallNonvirtualBooleanMethod (android_java_env,
+ emacs_service,
+ service_class.class,
+ method);
+ android_exception_check ();
+ return rc;
+}
+
void
android_set_dont_focus_on_map (android_window handle,
bool no_focus_on_map)
@@ -6701,7 +6746,7 @@ static void *android_query_context;
/* Run any function that the UI thread has asked to run, and then
signal its completion. */
-static void
+void
android_check_query (void)
{
void (*proc) (void *);
diff --git a/src/android.h b/src/android.h
index 2f5f32037c5..e1834cebf68 100644
--- a/src/android.h
+++ b/src/android.h
@@ -24,6 +24,8 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
a table of function pointers. */
#ifndef _ANDROID_H_
+#define _ANDROID_H_
+
#ifndef ANDROID_STUBIFY
#include <jni.h>
#include <pwd.h>
@@ -103,6 +105,7 @@ extern int android_get_screen_height (void);
extern int android_get_mm_width (void);
extern int android_get_mm_height (void);
extern bool android_detect_mouse (void);
+extern bool android_detect_keyboard (void);
extern void android_set_dont_focus_on_map (android_window, bool);
extern void android_set_dont_accept_focus (android_window, bool);
@@ -225,6 +228,7 @@ extern void android_display_toast (const char *);
/* Event loop functions. */
+extern void android_check_query (void);
extern void android_check_query_urgent (void);
extern int android_run_in_emacs_thread (void (*) (void *), void *);
extern void android_write_event (union android_event *);
@@ -265,6 +269,7 @@ struct android_emacs_service
jmethodID get_screen_width;
jmethodID get_screen_height;
jmethodID detect_mouse;
+ jmethodID detect_keyboard;
jmethodID name_keysym;
jmethodID browse_url;
jmethodID restart_emacs;
@@ -297,6 +302,10 @@ struct android_emacs_service
extern JNIEnv *android_java_env;
+#ifdef THREADS_ENABLED
+extern JavaVM *android_jvm;
+#endif /* THREADS_ENABLED */
+
/* The EmacsService object. */
extern jobject emacs_service;
diff --git a/src/androidfns.c b/src/androidfns.c
index eaecb78338b..0675a0a3c98 100644
--- a/src/androidfns.c
+++ b/src/androidfns.c
@@ -2287,6 +2287,57 @@ DEFUN ("x-show-tip", Fx_show_tip, Sx_show_tip, 1, 6, 0,
goto start_timer;
}
+ else if (tooltip_reuse_hidden_frame && BASE_EQ (frame, tip_last_frame))
+ {
+ bool delete = false;
+ Lisp_Object tail, elt, parm, last;
+
+ /* Check if every parameter in PARMS has the same value in
+ tip_last_parms. This may destruct tip_last_parms which,
+ however, will be recreated below. */
+ for (tail = parms; CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ parm = CAR (elt);
+ /* The left, top, right and bottom parameters are handled
+ by compute_tip_xy so they can be ignored here. */
+ if (!EQ (parm, Qleft) && !EQ (parm, Qtop)
+ && !EQ (parm, Qright) && !EQ (parm, Qbottom))
+ {
+ last = Fassq (parm, tip_last_parms);
+ if (NILP (Fequal (CDR (elt), CDR (last))))
+ {
+ /* We lost, delete the old tooltip. */
+ delete = true;
+ break;
+ }
+ else
+ tip_last_parms
+ = call2 (Qassq_delete_all, parm, tip_last_parms);
+ }
+ else
+ tip_last_parms
+ = call2 (Qassq_delete_all, parm, tip_last_parms);
+ }
+
+ /* Now check if every parameter in what is left of
+ tip_last_parms with a non-nil value has an association in
+ PARMS. */
+ for (tail = tip_last_parms; CONSP (tail); tail = XCDR (tail))
+ {
+ elt = XCAR (tail);
+ parm = CAR (elt);
+ if (!EQ (parm, Qleft) && !EQ (parm, Qtop) && !EQ (parm, Qright)
+ && !EQ (parm, Qbottom) && !NILP (CDR (elt)))
+ {
+ /* We lost, delete the old tooltip. */
+ delete = true;
+ break;
+ }
+ }
+
+ android_hide_tip (delete);
+ }
else
android_hide_tip (true);
}
@@ -2453,7 +2504,7 @@ DEFUN ("x-hide-tip", Fx_hide_tip, Sx_hide_tip, 0, 0, 0,
#endif /* 0 */
return Qnil;
#else /* !ANDROID_STUBIFY */
- return android_hide_tip (true);
+ return android_hide_tip (!tooltip_reuse_hidden_frame);
#endif /* ANDROID_STUBIFY */
}
@@ -2476,6 +2527,25 @@ there is no mouse. */)
#endif
}
+DEFUN ("android-detect-keyboard", Fandroid_detect_keyboard,
+ Sandroid_detect_keyboard, 0, 0, 0,
+ doc: /* Return whether a keyboard is connected.
+Return non-nil if a key is connected to this computer, or nil
+if there is no keyboard. */)
+ (void)
+{
+#ifndef ANDROID_STUBIFY
+ /* If no display connection is present, just return nil. */
+
+ if (!android_init_gui)
+ return Qnil;
+
+ return android_detect_keyboard () ? Qt : Qnil;
+#else /* ANDROID_STUBIFY */
+ return Qt;
+#endif /* ANDROID_STUBIFY */
+}
+
DEFUN ("android-toggle-on-screen-keyboard",
Fandroid_toggle_on_screen_keyboard,
Sandroid_toggle_on_screen_keyboard, 2, 2, 0,
@@ -3197,6 +3267,10 @@ syms_of_androidfns_for_pdumper (void)
jstring string;
Lisp_Object language, country, script, variant;
const char *data;
+ FILE *fd;
+ char *line;
+ size_t size;
+ long pid;
/* Find the Locale class. */
@@ -3367,6 +3441,35 @@ syms_of_androidfns_for_pdumper (void)
/* Set Vandroid_os_language. */
Vandroid_os_language = list4 (language, country, script, variant);
+
+ /* Detect whether Emacs is running under libloader.so or another
+ process tracing mechanism, and disable `android_use_exec_loader' if
+ so, leaving subprocesses started by Emacs to the care of that
+ loader instance. */
+
+ if (android_get_current_api_level () >= 29) /* Q */
+ {
+ fd = fopen ("/proc/self/status", "r");
+ if (!fd)
+ return;
+
+ line = NULL;
+ while (getline (&line, &size, fd) != -1)
+ {
+ if (strncmp (line, "TracerPid:", sizeof "TracerPid:" - 1))
+ continue;
+
+ pid = atol (line + sizeof "TracerPid:" - 1);
+
+ if (pid)
+ android_use_exec_loader = false;
+
+ break;
+ }
+
+ free (line);
+ fclose (fd);
+ }
}
#endif /* ANDROID_STUBIFY */
@@ -3560,6 +3663,7 @@ language to be US English if LANGUAGE is empty. */);
defsubr (&Sx_show_tip);
defsubr (&Sx_hide_tip);
defsubr (&Sandroid_detect_mouse);
+ defsubr (&Sandroid_detect_keyboard);
defsubr (&Sandroid_toggle_on_screen_keyboard);
defsubr (&Sx_server_vendor);
defsubr (&Sx_server_version);
diff --git a/src/androidselect.c b/src/androidselect.c
index 5b23c559d2c..61f1c6045db 100644
--- a/src/androidselect.c
+++ b/src/androidselect.c
@@ -237,15 +237,21 @@ DEFUN ("android-clipboard-exists-p",
Fandroid_clipboard_exists_p,
return rc ? Qt : Qnil;
}
-DEFUN ("android-browse-url", Fandroid_browse_url,
- Sandroid_browse_url, 1, 2, 0,
- doc: /* Open URL in an external application. URL should be a
-URL-encoded URL with a scheme specified unless SEND is non-nil.
-Signal an error upon failure.
+DEFUN ("android-browse-url-internal", Fandroid_browse_url_internal,
+ Sandroid_browse_url_internal, 1, 2, 0,
+ doc: /* Open URL in an external application.
+
+URL should be a URL-encoded URL with a scheme specified unless SEND is
+non-nil. Signal an error upon failure.
If SEND is nil, start a program that is able to display the URL, such
as a web browser. Otherwise, try to share URL using programs such as
-email clients. */)
+email clients.
+
+If URL is a file URI, convert it into a `content' address accessible to
+other programs. Files inside the /content or /assets directories cannot
+be opened through such addresses, which this function does not provide
+for. Use `android-browse-url' instead. */)
(Lisp_Object url, Lisp_Object send)
{
Lisp_Object value;
@@ -803,7 +809,7 @@ syms_of_androidselect (void)
defsubr (&Sandroid_set_clipboard);
defsubr (&Sandroid_get_clipboard);
defsubr (&Sandroid_clipboard_exists_p);
- defsubr (&Sandroid_browse_url);
+ defsubr (&Sandroid_browse_url_internal);
defsubr (&Sandroid_get_clipboard_targets);
defsubr (&Sandroid_get_clipboard_data);
diff --git a/src/androidterm.c b/src/androidterm.c
index d4612bb20fa..2bd2b45743d 100644
--- a/src/androidterm.c
+++ b/src/androidterm.c
@@ -495,8 +495,8 @@ android_note_mouse_movement (struct frame *frame,
/* Has the mouse moved off the glyph it was on at the last sighting? */
r = &dpyinfo->last_mouse_glyph;
if (frame != dpyinfo->last_mouse_glyph_frame
- || event->x < r->x || event->x >= r->x + r->width
- || event->y < r->y || event->y >= r->y + r->height)
+ || event->x < r->x || event->x >= r->x + (int) r->width
+ || event->y < r->y || event->y >= r->y + (int) r->height)
{
frame->mouse_moved = true;
note_mouse_highlight (frame, event->x, event->y);
diff --git a/src/androidvfs.c b/src/androidvfs.c
index 78f6b6da6a8..d618e351204 100644
--- a/src/androidvfs.c
+++ b/src/androidvfs.c
@@ -1018,8 +1018,8 @@ android_extract_long (char *pointer)
static const char *
android_scan_directory_tree (char *file, size_t *limit_return)
{
- char *token, *saveptr, *copy, *copy1, *start, *max, *limit;
- size_t token_length, ntokens, i;
+ char *token, *saveptr, *copy, *start, *max, *limit;
+ size_t token_length, ntokens, i, len;
char *tokens[10];
USE_SAFE_ALLOCA;
@@ -1031,11 +1031,14 @@ android_scan_directory_tree (char *file, size_t
*limit_return)
limit = (char *) directory_tree + directory_tree_size;
/* Now, split `file' into tokens, with the delimiter being the file
- name separator. Look for the file and seek past it. */
+ name separator. Look for the file and seek past it. Create a copy
+ of FILE for the enjoyment of `strtok_r'. */
ntokens = 0;
saveptr = NULL;
- copy = copy1 = xstrdup (file);
+ len = strlen (file) + 1;
+ copy = SAFE_ALLOCA (len);
+ memcpy (copy, file, len);
memset (tokens, 0, sizeof tokens);
while ((token = strtok_r (copy, "/", &saveptr)))
@@ -1044,19 +1047,14 @@ android_scan_directory_tree (char *file, size_t
*limit_return)
/* Make sure ntokens is within bounds. */
if (ntokens == ARRAYELTS (tokens))
- {
- xfree (copy1);
- goto fail;
- }
+ goto fail;
- tokens[ntokens] = SAFE_ALLOCA (strlen (token) + 1);
- memcpy (tokens[ntokens], token, strlen (token) + 1);
+ len = strlen (token) + 1;
+ tokens[ntokens] = SAFE_ALLOCA (len);
+ memcpy (tokens[ntokens], token, len);
ntokens++;
}
- /* Free the copy created for strtok_r. */
- xfree (copy1);
-
/* If there are no tokens, just return the start of the directory
tree. */
@@ -6319,6 +6317,8 @@ static sem_t saf_completion_sem;
JNIEXPORT jint JNICALL
NATIVE_NAME (safSyncAndReadInput) (JNIEnv *env, jobject object)
{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
while (sem_wait (&saf_completion_sem) < 0)
{
if (input_blocked_p ())
@@ -6340,6 +6340,8 @@ NATIVE_NAME (safSyncAndReadInput) (JNIEnv *env, jobject
object)
JNIEXPORT void JNICALL
NATIVE_NAME (safSync) (JNIEnv *env, jobject object)
{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
while (sem_wait (&saf_completion_sem) < 0)
process_pending_signals ();
}
@@ -6347,12 +6349,16 @@ NATIVE_NAME (safSync) (JNIEnv *env, jobject object)
JNIEXPORT void JNICALL
NATIVE_NAME (safPostRequest) (JNIEnv *env, jobject object)
{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
sem_post (&saf_completion_sem);
}
JNIEXPORT jboolean JNICALL
NATIVE_NAME (ftruncate) (JNIEnv *env, jobject object, jint fd)
{
+ JNI_STACK_ALIGNMENT_PROLOGUE;
+
if (ftruncate (fd, 0) < 0)
return false;
diff --git a/src/buffer.c b/src/buffer.c
index 352aca8ddfd..e235ff8f9f8 100644
--- a/src/buffer.c
+++ b/src/buffer.c
@@ -1334,7 +1334,7 @@ buffer_local_value (Lisp_Object variable, Lisp_Object
buffer)
case SYMBOL_LOCALIZED:
{ /* Look in local_var_alist. */
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
- XSETSYMBOL (variable, sym); /* Update In case of aliasing. */
+ variable = make_lisp_symbol (sym); /* Update In case of aliasing. */
result = assq_no_quit (variable, BVAR (buf, local_var_alist));
if (!NILP (result))
{
@@ -3002,7 +3002,7 @@ the normal hook `change-major-mode-hook'. */)
But still return the total number of overlays.
*/
-ptrdiff_t
+static ptrdiff_t
overlays_in (ptrdiff_t beg, ptrdiff_t end, bool extend,
Lisp_Object **vec_ptr, ptrdiff_t *len_ptr,
bool empty, bool trailing,
@@ -3125,56 +3125,38 @@ mouse_face_overlay_overlaps (Lisp_Object overlay)
{
ptrdiff_t start = OVERLAY_START (overlay);
ptrdiff_t end = OVERLAY_END (overlay);
- ptrdiff_t n, i, size;
- Lisp_Object *v, tem;
- Lisp_Object vbuf[10];
- USE_SAFE_ALLOCA;
+ Lisp_Object tem;
+ struct itree_node *node;
- size = ARRAYELTS (vbuf);
- v = vbuf;
- n = overlays_in (start, end, 0, &v, &size, true, false, NULL);
- if (n > size)
+ ITREE_FOREACH (node, current_buffer->overlays,
+ start, min (end, ZV) + 1,
+ ASCENDING)
{
- SAFE_NALLOCA (v, 1, n);
- overlays_in (start, end, 0, &v, &n, true, false, NULL);
+ if (node->begin < end && node->end > start
+ && node->begin < node->end
+ && !EQ (node->data, overlay)
+ && (tem = Foverlay_get (overlay, Qmouse_face),
+ !NILP (tem)))
+ return true;
}
-
- for (i = 0; i < n; ++i)
- if (!EQ (v[i], overlay)
- && (tem = Foverlay_get (overlay, Qmouse_face),
- !NILP (tem)))
- break;
-
- SAFE_FREE ();
- return i < n;
+ return false;
}
/* Return the value of the 'display-line-numbers-disable' property at
EOB, if there's an overlay at ZV with a non-nil value of that property. */
-Lisp_Object
+bool
disable_line_numbers_overlay_at_eob (void)
{
- ptrdiff_t n, i, size;
- Lisp_Object *v, tem = Qnil;
- Lisp_Object vbuf[10];
- USE_SAFE_ALLOCA;
+ Lisp_Object tem = Qnil;
+ struct itree_node *node;
- size = ARRAYELTS (vbuf);
- v = vbuf;
- n = overlays_in (ZV, ZV, 0, &v, &size, false, false, NULL);
- if (n > size)
+ ITREE_FOREACH (node, current_buffer->overlays, ZV, ZV, ASCENDING)
{
- SAFE_NALLOCA (v, 1, n);
- overlays_in (ZV, ZV, 0, &v, &n, false, false, NULL);
+ if ((tem = Foverlay_get (node->data, Qdisplay_line_numbers_disable),
+ !NILP (tem)))
+ return true;
}
-
- for (i = 0; i < n; ++i)
- if ((tem = Foverlay_get (v[i], Qdisplay_line_numbers_disable),
- !NILP (tem)))
- break;
-
- SAFE_FREE ();
- return tem;
+ return false;
}
@@ -4989,7 +4971,7 @@ defvar_per_buffer (struct Lisp_Buffer_Objfwd *bo_fwd,
const char *namestring,
sym->u.s.declared_special = true;
sym->u.s.redirect = SYMBOL_FORWARDED;
SET_SYMBOL_FWD (sym, bo_fwd);
- XSETSYMBOL (PER_BUFFER_SYMBOL (offset), sym);
+ PER_BUFFER_SYMBOL (offset) = make_lisp_symbol (sym);
if (PER_BUFFER_IDX (offset) == 0)
/* Did a DEFVAR_PER_BUFFER without initializing the corresponding
diff --git a/src/buffer.h b/src/buffer.h
index 9e0982f5da7..87ba2802b39 100644
--- a/src/buffer.h
+++ b/src/buffer.h
@@ -1174,8 +1174,6 @@ extern void delete_all_overlays (struct buffer *);
extern void reset_buffer (struct buffer *);
extern void compact_buffer (struct buffer *);
extern ptrdiff_t overlays_at (ptrdiff_t, bool, Lisp_Object **, ptrdiff_t *,
ptrdiff_t *);
-extern ptrdiff_t overlays_in (ptrdiff_t, ptrdiff_t, bool, Lisp_Object **,
- ptrdiff_t *, bool, bool, ptrdiff_t *);
extern ptrdiff_t previous_overlay_change (ptrdiff_t);
extern ptrdiff_t next_overlay_change (ptrdiff_t);
extern ptrdiff_t sort_overlays (Lisp_Object *, ptrdiff_t, struct window *);
diff --git a/src/bytecode.c b/src/bytecode.c
index ed6e2b34e77..8d7240b9966 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -625,9 +625,10 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
varref:
{
Lisp_Object v1 = vectorp[op], v2;
- if (!SYMBOLP (v1)
- || XSYMBOL (v1)->u.s.redirect != SYMBOL_PLAINVAL
- || (v2 = SYMBOL_VAL (XSYMBOL (v1)), BASE_EQ (v2, Qunbound)))
+ if (!BARE_SYMBOL_P (v1)
+ || XBARE_SYMBOL (v1)->u.s.redirect != SYMBOL_PLAINVAL
+ || (v2 = XBARE_SYMBOL (v1)->u.s.val.value,
+ BASE_EQ (v2, Qunbound)))
v2 = Fsymbol_value (v1);
PUSH (v2);
NEXT;
@@ -699,11 +700,11 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
Lisp_Object val = POP;
/* Inline the most common case. */
- if (SYMBOLP (sym)
+ if (BARE_SYMBOL_P (sym)
&& !BASE_EQ (val, Qunbound)
- && XSYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL
- && !SYMBOL_TRAPPED_WRITE_P (sym))
- SET_SYMBOL_VAL (XSYMBOL (sym), val);
+ && XBARE_SYMBOL (sym)->u.s.redirect == SYMBOL_PLAINVAL
+ && !XBARE_SYMBOL (sym)->u.s.trapped_write)
+ SET_SYMBOL_VAL (XBARE_SYMBOL (sym), val);
else
set_internal (sym, val, Qnil, SET_INTERNAL_SET);
}
@@ -790,24 +791,22 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
do_debug_on_call (Qlambda, count1);
Lisp_Object original_fun = call_fun;
- if (SYMBOLP (call_fun))
- call_fun = XSYMBOL (call_fun)->u.s.function;
- Lisp_Object template;
- Lisp_Object bytecode;
- if (COMPILEDP (call_fun)
- /* Lexical binding only. */
- && (template = AREF (call_fun, COMPILED_ARGLIST),
- FIXNUMP (template))
- /* No autoloads. */
- && (bytecode = AREF (call_fun, COMPILED_BYTECODE),
- !CONSP (bytecode)))
+ /* Calls to symbols-with-pos don't need to be on the fast path. */
+ if (BARE_SYMBOL_P (call_fun))
+ call_fun = XBARE_SYMBOL (call_fun)->u.s.function;
+ if (COMPILEDP (call_fun))
{
- fun = call_fun;
- bytestr = bytecode;
- args_template = XFIXNUM (template);
- nargs = call_nargs;
- args = call_args;
- goto setup_frame;
+ Lisp_Object template = AREF (call_fun, COMPILED_ARGLIST);
+ if (FIXNUMP (template))
+ {
+ /* Fast path for lexbound functions. */
+ fun = call_fun;
+ bytestr = AREF (call_fun, COMPILED_BYTECODE),
+ args_template = XFIXNUM (template);
+ nargs = call_nargs;
+ args = call_args;
+ goto setup_frame;
+ }
}
Lisp_Object val;
@@ -1738,28 +1737,29 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t
args_template,
if (BYTE_CODE_SAFE && !HASH_TABLE_P (jmp_table))
emacs_abort ();
Lisp_Object v1 = POP;
- ptrdiff_t i;
struct Lisp_Hash_Table *h = XHASH_TABLE (jmp_table);
-
- /* h->count is a faster approximation for HASH_TABLE_SIZE (h)
- here. */
- if (h->count <= 5 && !h->test->cmpfn)
- { /* Do a linear search if there are not many cases
- FIXME: 5 is arbitrarily chosen. */
- for (i = h->count; 0 <= --i; )
- if (EQ (v1, HASH_KEY (h, i)))
- break;
+ /* Do a linear search if there are few cases and the test is `eq'.
+ (The table is assumed to be sized exactly; all entries are
+ consecutive at the beginning.)
+ FIXME: 5 is arbitrarily chosen. */
+ if (h->count <= 5 && !h->test->cmpfn && !symbols_with_pos_enabled)
+ {
+ eassume (h->count >= 2);
+ for (ptrdiff_t i = h->count - 1; i >= 0; i--)
+ if (BASE_EQ (v1, HASH_KEY (h, i)))
+ {
+ op = XFIXNUM (HASH_VALUE (h, i));
+ goto op_branch;
+ }
}
else
- i = hash_lookup (h, v1);
-
- if (i >= 0)
{
- Lisp_Object val = HASH_VALUE (h, i);
- if (BYTE_CODE_SAFE && !FIXNUMP (val))
- emacs_abort ();
- op = XFIXNUM (val);
- goto op_branch;
+ ptrdiff_t i = hash_lookup (h, v1);
+ if (i >= 0)
+ {
+ op = XFIXNUM (HASH_VALUE (h, i));
+ goto op_branch;
+ }
}
}
NEXT;
diff --git a/src/ccl.c b/src/ccl.c
index a3a03a5b7b1..8bb8a78fe3d 100644
--- a/src/ccl.c
+++ b/src/ccl.c
@@ -35,11 +35,6 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "coding.h"
#include "keyboard.h"
-/* Avoid GCC 12 bug <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=105784>. */
-#if GNUC_PREREQ (12, 0, 0)
-# pragma GCC diagnostic ignored "-Wanalyzer-use-of-uninitialized-value"
-#endif
-
/* Table of registered CCL programs. Each element is a vector of
NAME, CCL_PROG, RESOLVEDP, and UPDATEDP, where NAME (symbol) is the
name of the program, CCL_PROG (vector) is the compiled code of the
@@ -609,7 +604,7 @@ while (0)
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109579
which causes GCC to mistakenly complain about
popping the mapping stack. */
-#if GNUC_PREREQ (13, 0, 0)
+#if __GNUC__ == 13
# pragma GCC diagnostic ignored "-Wanalyzer-out-of-bounds"
#endif
diff --git a/src/comp.c b/src/comp.c
index 853757f6162..3f989c722d4 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -4859,8 +4859,8 @@ add_compiler_options (void)
#endif
}
-DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
- Scomp__compile_ctxt_to_file,
+DEFUN ("comp--compile-ctxt-to-file0", Fcomp__compile_ctxt_to_file0,
+ Scomp__compile_ctxt_to_file0,
1, 1, 0,
doc: /* Compile the current context as native code to file FILENAME.
*/)
(Lisp_Object filename)
@@ -5789,7 +5789,7 @@ natively-compiled one. */);
defsubr (&Scomp__install_trampoline);
defsubr (&Scomp__init_ctxt);
defsubr (&Scomp__release_ctxt);
- defsubr (&Scomp__compile_ctxt_to_file);
+ defsubr (&Scomp__compile_ctxt_to_file0);
defsubr (&Scomp_libgccjit_version);
defsubr (&Scomp__register_lambda);
defsubr (&Scomp__register_subr);
diff --git a/src/conf_post.h b/src/conf_post.h
index 83a0dd1b09b..f2353803074 100644
--- a/src/conf_post.h
+++ b/src/conf_post.h
@@ -471,3 +471,7 @@ extern int emacs_setenv_TZ (char const *);
#undef MB_CUR_MAX
#define MB_CUR_MAX REPLACEMENT_MB_CUR_MAX
#endif /* REPLACEMENT_MB_CUR_MAX */
+
+/* Emacs does not need glibc strftime behavior for AM and PM
+ indicators. */
+#define REQUIRE_GNUISH_STRFTIME_AM_PM false
diff --git a/src/data.c b/src/data.c
index fd4b1fe4e44..c87b5317618 100644
--- a/src/data.c
+++ b/src/data.c
@@ -231,6 +231,7 @@ for example, (type-of 1) returns `integer'. */)
case PVEC_BOOL_VECTOR: return Qbool_vector;
case PVEC_FRAME: return Qframe;
case PVEC_HASH_TABLE: return Qhash_table;
+ case PVEC_OBARRAY: return Qobarray;
case PVEC_FONT:
if (FONT_SPEC_P (object))
return Qfont_spec;
@@ -791,18 +792,16 @@ DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0,
doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */)
(register Lisp_Object sym)
{
- if (BARE_SYMBOL_P (sym))
- return sym;
- /* Type checking is done in the following macro. */
- return SYMBOL_WITH_POS_SYM (sym);
+ CHECK_SYMBOL (sym);
+ return BARE_SYMBOL_P (sym) ? sym : XSYMBOL_WITH_POS_SYM (sym);
}
DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1,
1, 0,
doc: /* Extract the position from a symbol with position. */)
(register Lisp_Object ls)
{
- /* Type checking is done in the following macro. */
- return SYMBOL_WITH_POS_POS (ls);
+ CHECK_TYPE (SYMBOL_WITH_POS_P (ls), Qsymbol_with_pos_p, ls);
+ return XSYMBOL_WITH_POS_POS (ls);
}
DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol,
@@ -812,7 +811,7 @@ Otherwise, return ARG unchanged. Compare with
`bare-symbol'. */)
(register Lisp_Object arg)
{
if (SYMBOL_WITH_POS_P (arg))
- return (SYMBOL_WITH_POS_SYM (arg));
+ return XSYMBOL_WITH_POS_SYM (arg);
return arg;
}
@@ -823,20 +822,13 @@ POS, the position, is either a fixnum or a symbol with
position from which
the position will be taken. */)
(register Lisp_Object sym, register Lisp_Object pos)
{
- Lisp_Object bare;
+ Lisp_Object bare = Fbare_symbol (sym);
Lisp_Object position;
- if (BARE_SYMBOL_P (sym))
- bare = sym;
- else if (SYMBOL_WITH_POS_P (sym))
- bare = XSYMBOL_WITH_POS (sym)->sym;
- else
- wrong_type_argument (Qsymbolp, sym);
-
if (FIXNUMP (pos))
position = pos;
else if (SYMBOL_WITH_POS_P (pos))
- position = XSYMBOL_WITH_POS (pos)->pos;
+ position = XSYMBOL_WITH_POS_POS (pos);
else
wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos);
@@ -1264,7 +1256,7 @@ If OBJECT is not a symbol, just return it. */)
struct Lisp_Symbol *sym = XSYMBOL (object);
while (sym->u.s.redirect == SYMBOL_VARALIAS)
sym = SYMBOL_ALIAS (sym);
- XSETSYMBOL (object, sym);
+ object = make_lisp_symbol (sym);
}
return object;
}
@@ -1514,12 +1506,9 @@ swap_in_symval_forwarding (struct Lisp_Symbol *symbol,
struct Lisp_Buffer_Local_
if (blv->fwd.fwdptr)
set_blv_value (blv, do_symval_forwarding (blv->fwd));
/* Choose the new binding. */
- {
- Lisp_Object var;
- XSETSYMBOL (var, symbol);
- tem1 = assq_no_quit (var, BVAR (current_buffer, local_var_alist));
- set_blv_where (blv, Fcurrent_buffer ());
- }
+ tem1 = assq_no_quit (make_lisp_symbol (symbol),
+ BVAR (current_buffer, local_var_alist));
+ set_blv_where (blv, Fcurrent_buffer ());
if (!(blv->found = !NILP (tem1)))
tem1 = blv->defcell;
@@ -1663,7 +1652,8 @@ set_internal (Lisp_Object symbol, Lisp_Object newval,
Lisp_Object where,
set_blv_value (blv, do_symval_forwarding (blv->fwd));
/* Find the new binding. */
- XSETSYMBOL (symbol, sym); /* May have changed via aliasing. */
+ /* May have changed via aliasing. */
+ symbol = make_lisp_symbol (sym);
Lisp_Object tem1
= assq_no_quit (symbol,
BVAR (XBUFFER (where), local_var_alist));
@@ -2067,13 +2057,10 @@ make_blv (struct Lisp_Symbol *sym, bool forwarded,
union Lisp_Val_Fwd valcontents)
{
struct Lisp_Buffer_Local_Value *blv = xmalloc (sizeof *blv);
- Lisp_Object symbol;
- Lisp_Object tem;
-
- XSETSYMBOL (symbol, sym);
- tem = Fcons (symbol, (forwarded
- ? do_symval_forwarding (valcontents.fwd)
- : valcontents.value));
+ Lisp_Object tem = Fcons (make_lisp_symbol (sym),
+ forwarded
+ ? do_symval_forwarding (valcontents.fwd)
+ : valcontents.value);
/* Buffer_Local_Values cannot have as realval a buffer-local
or keyboard-local forwarding. */
@@ -2229,7 +2216,7 @@ Instead, use `add-hook' and specify t for the LOCAL
argument. */)
}
/* Make sure this buffer has its own value of symbol. */
- XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
+ variable = make_lisp_symbol (sym); /* Update in case of aliasing. */
tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist));
if (NILP (tem))
{
@@ -2309,7 +2296,7 @@ From now on the default value will apply in this buffer.
Return VARIABLE. */)
notify_variable_watchers (variable, Qnil, Qmakunbound, Fcurrent_buffer ());
/* Get rid of this buffer's alist element, if any. */
- XSETSYMBOL (variable, sym); /* Propagate variable indirection. */
+ variable = make_lisp_symbol (sym); /* Propagate variable indirection. */
tem = assq_no_quit (variable, BVAR (current_buffer, local_var_alist));
if (!NILP (tem))
bset_local_var_alist
@@ -2354,7 +2341,7 @@ Also see `buffer-local-boundp'.*/)
Lisp_Object tmp;
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
XSETBUFFER (tmp, buf);
- XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
+ variable = make_lisp_symbol (sym); /* Update in case of aliasing. */
if (EQ (blv->where, tmp)) /* The binding is already loaded. */
return blv_found (blv) ? Qt : Qnil;
@@ -2404,7 +2391,7 @@ value in BUFFER, or if VARIABLE is automatically
buffer-local (see
struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
if (blv->local_if_set)
return Qt;
- XSETSYMBOL (variable, sym); /* Update in case of aliasing. */
+ variable = make_lisp_symbol (sym); /* Update in case of aliasing. */
return Flocal_variable_p (variable, buffer);
}
case SYMBOL_FORWARDED:
@@ -4238,6 +4225,7 @@ syms_of_data (void)
DEFSYM (Qtreesit_parser, "treesit-parser");
DEFSYM (Qtreesit_node, "treesit-node");
DEFSYM (Qtreesit_compiled_query, "treesit-compiled-query");
+ DEFSYM (Qobarray, "obarray");
DEFSYM (Qdefun, "defun");
diff --git a/src/dispextern.h b/src/dispextern.h
index 84b9dadc184..5387cb45603 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -2752,6 +2752,16 @@ struct it
pixel_width with each call to produce_glyphs. */
int current_x;
+ /* Pixel position within a display line with a wrap prefix. Updated
+ to reflect current_x in produce_glyphs when producing glyphs from
+ a prefix string and continuation_lines_width > 0, which is to
+ say, from a wrap prefix.
+
+ Such updates are unnecessary where it is impossible for a wrap
+ prefix to be active, e.g. when continuation lines are being
+ produced. */
+ int wrap_prefix_width;
+
/* Accumulated width of continuation lines. If > 0, this means we
are currently in a continuation line. This is initially zero and
incremented/reset by display_line, move_it_to etc. */
diff --git a/src/doc.c b/src/doc.c
index a451b468ef2..b5a9ed498af 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -357,6 +357,20 @@ reread_doc_file (Lisp_Object file)
return 1;
}
+DEFUN ("documentation-stringp", Fdocumentation_stringp, Sdocumentation_stringp,
+ 1, 1, 0,
+ doc: /* Return non-nil if OBJECT is a well-formed docstring object.
+OBJECT can be either a string or a reference if it's kept externally. */)
+ (Lisp_Object object)
+{
+ return (STRINGP (object)
+ || FIXNUMP (object) /* Reference to DOC. */
+ || (CONSP (object) /* Reference to .elc. */
+ && STRINGP (XCAR (object))
+ && FIXNUMP (XCDR (object)))
+ ? Qt : Qnil);
+}
+
DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 2, 0,
doc: /* Return the documentation string of FUNCTION.
Unless a non-nil second argument RAW is given, the
@@ -502,46 +516,13 @@ store_function_docstring (Lisp_Object obj, EMACS_INT
offset)
/* If it's a lisp form, stick it in the form. */
if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
fun = XCDR (fun);
- if (CONSP (fun))
- {
- Lisp_Object tem = XCAR (fun);
- if (EQ (tem, Qlambda) || EQ (tem, Qautoload)
- || (EQ (tem, Qclosure) && (fun = XCDR (fun), 1)))
- {
- tem = Fcdr (Fcdr (fun));
- if (CONSP (tem) && FIXNUMP (XCAR (tem)))
- /* FIXME: This modifies typically pure hash-cons'd data, so its
- correctness is quite delicate. */
- XSETCAR (tem, make_fixnum (offset));
- }
- }
/* Lisp_Subrs have a slot for it. */
- else if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun))
- {
- XSUBR (fun)->doc = offset;
- }
-
- /* Bytecode objects sometimes have slots for it. */
- else if (COMPILEDP (fun))
+ if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun))
+ XSUBR (fun)->doc = offset;
+ else
{
- /* This bytecode object must have a slot for the
- docstring, since we've found a docstring for it. */
- if (PVSIZE (fun) > COMPILED_DOC_STRING
- /* Don't overwrite a non-docstring value placed there,
- * such as the symbols used for Oclosures. */
- && VALID_DOCSTRING_P (AREF (fun, COMPILED_DOC_STRING)))
- ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset));
- else
- {
- AUTO_STRING (format,
- (PVSIZE (fun) > COMPILED_DOC_STRING
- ? "Docstring slot busy for %s"
- : "No docstring slot for %s"));
- CALLN (Fmessage, format,
- (SYMBOLP (obj)
- ? SYMBOL_NAME (obj)
- : build_string ("<anonymous>")));
- }
+ AUTO_STRING (format, "Ignoring DOC string on non-subr: %S");
+ CALLN (Fmessage, format, obj);
}
}
@@ -776,6 +757,7 @@ compute the correct value for the current terminal in the
nil case. */);
doc: /* If nil, a nil `text-quoting-style' is treated as
`grave'. */);
/* Initialized by ‘main’. */
+ defsubr (&Sdocumentation_stringp);
defsubr (&Sdocumentation);
defsubr (&Ssubr_documentation);
defsubr (&Sdocumentation_property);
diff --git a/src/editfns.c b/src/editfns.c
index 0cecd81c07f..4ccf765bd4b 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -272,24 +272,6 @@ If you set the marker not to point anywhere, the buffer
will have no mark. */)
}
-/* Find all the overlays in the current buffer that touch position POS.
- Return the number found, and store them in a vector in VEC
- of length LEN.
-
- Note: this can return overlays that do not touch POS. The caller
- should filter these out. */
-
-static ptrdiff_t
-overlays_around (ptrdiff_t pos, Lisp_Object *vec, ptrdiff_t len)
-{
- /* Find all potentially rear-advance overlays at (POS - 1). Find
- all overlays at POS, so end at (POS + 1). Find even empty
- overlays, which due to the way 'overlays-in' works implies that
- we might also fetch empty overlays starting at (POS + 1). */
- return overlays_in (pos - 1, pos + 1, false, &vec, &len,
- true, false, NULL);
-}
-
DEFUN ("get-pos-property", Fget_pos_property, Sget_pos_property, 2, 3, 0,
doc: /* Return the value of POSITION's property PROP, in OBJECT.
Almost identical to `get-char-property' except for the following difference:
@@ -315,53 +297,44 @@ at POSITION. */)
else
{
EMACS_INT posn = XFIXNUM (position);
- ptrdiff_t noverlays;
- Lisp_Object *overlay_vec, tem;
+ Lisp_Object tem;
struct buffer *obuf = current_buffer;
- USE_SAFE_ALLOCA;
-
- set_buffer_temp (XBUFFER (object));
+ struct itree_node *node;
+ struct sortvec items[2];
+ struct buffer *b = XBUFFER (object);
+ struct sortvec *result = NULL;
+ Lisp_Object res = Qnil;
- /* First try with room for 40 overlays. */
- Lisp_Object overlay_vecbuf[40];
- noverlays = ARRAYELTS (overlay_vecbuf);
- overlay_vec = overlay_vecbuf;
- noverlays = overlays_around (posn, overlay_vec, noverlays);
+ set_buffer_temp (b);
- /* If there are more than 40,
- make enough space for all, and try again. */
- if (ARRAYELTS (overlay_vecbuf) < noverlays)
+ ITREE_FOREACH (node, b->overlays, posn - 1, posn + 1, ASCENDING)
{
- SAFE_ALLOCA_LISP (overlay_vec, noverlays);
- noverlays = overlays_around (posn, overlay_vec, noverlays);
- }
- noverlays = sort_overlays (overlay_vec, noverlays, NULL);
-
- set_buffer_temp (obuf);
-
- /* Now check the overlays in order of decreasing priority. */
- while (--noverlays >= 0)
- {
- Lisp_Object ol = overlay_vec[noverlays];
+ Lisp_Object ol = node->data;
tem = Foverlay_get (ol, prop);
- if (!NILP (tem))
- {
+ if (NILP (tem)
/* Check the overlay is indeed active at point. */
- if ((OVERLAY_START (ol) == posn
+ || ((node->begin == posn
&& OVERLAY_FRONT_ADVANCE_P (ol))
- || (OVERLAY_END (ol) == posn
+ || (node->end == posn
&& ! OVERLAY_REAR_ADVANCE_P (ol))
- || OVERLAY_START (ol) > posn
- || OVERLAY_END (ol) < posn)
- ; /* The overlay will not cover a char inserted at point. */
- else
- {
- SAFE_FREE ();
- return tem;
- }
- }
+ || node->begin > posn
+ || node->end < posn))
+ /* The overlay will not cover a char inserted at point. */
+ continue;
+
+ struct sortvec *this = (result == items ? items + 1 : items);
+ if (NILP (res)
+ || (make_sortvec_item (this, node->data),
+ compare_overlays (result, this) < 0))
+ {
+ result = this;
+ res = tem;
+ }
}
- SAFE_FREE ();
+ set_buffer_temp (obuf);
+
+ if (!NILP (res))
+ return res;
{ /* Now check the text properties. */
int stickiness = text_property_stickiness (prop, position, object);
diff --git a/src/emacs.c b/src/emacs.c
index 97c65fbfd33..f4bfb9a6bbd 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -3116,10 +3116,6 @@ shut_down_emacs (int sig, Lisp_Object stuff)
check_message_stack ();
}
-#ifdef HAVE_NATIVE_COMP
- eln_load_path_final_clean_up ();
-#endif
-
#ifdef MSDOS
dos_cleanup ();
#endif
diff --git a/src/eval.c b/src/eval.c
index 6f1c39ffb0e..9d3b98eb359 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -3122,19 +3122,6 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs,
Lisp_Object *args)
xsignal2 (Qwrong_number_of_arguments, fun, make_fixnum (numargs));
}
-/* Call the compiled Lisp function FUN. If we have not yet read FUN's
- bytecode string and constants vector, fetch them from the file first. */
-
-static Lisp_Object
-fetch_and_exec_byte_code (Lisp_Object fun, ptrdiff_t args_template,
- ptrdiff_t nargs, Lisp_Object *args)
-{
- if (CONSP (AREF (fun, COMPILED_BYTECODE)))
- Ffetch_bytecode (fun);
-
- return exec_byte_code (fun, args_template, nargs, args);
-}
-
static Lisp_Object
apply_lambda (Lisp_Object fun, Lisp_Object args, specpdl_ref count)
{
@@ -3204,8 +3191,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
ARGLIST slot value: pass the arguments to the byte-code
engine directly. */
if (FIXNUMP (syms_left))
- return fetch_and_exec_byte_code (fun, XFIXNUM (syms_left),
- nargs, arg_vector);
+ return exec_byte_code (fun, XFIXNUM (syms_left), nargs, arg_vector);
/* Otherwise the bytecode object uses dynamic binding and the
ARGLIST slot contains a standard formal argument list whose
variables are bound dynamically below. */
@@ -3293,7 +3279,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
val = XSUBR (fun)->function.a0 ();
}
else
- val = fetch_and_exec_byte_code (fun, 0, 0, NULL);
+ val = exec_byte_code (fun, 0, 0, NULL);
return unbind_to (count, val);
}
@@ -3411,46 +3397,6 @@ lambda_arity (Lisp_Object fun)
return Fcons (make_fixnum (minargs), make_fixnum (maxargs));
}
-DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode,
- 1, 1, 0,
- doc: /* If byte-compiled OBJECT is lazy-loaded, fetch it now. */)
- (Lisp_Object object)
-{
- Lisp_Object tem;
-
- if (COMPILEDP (object))
- {
- if (CONSP (AREF (object, COMPILED_BYTECODE)))
- {
- tem = read_doc_string (AREF (object, COMPILED_BYTECODE));
- if (! (CONSP (tem) && STRINGP (XCAR (tem))
- && VECTORP (XCDR (tem))))
- {
- tem = AREF (object, COMPILED_BYTECODE);
- if (CONSP (tem) && STRINGP (XCAR (tem)))
- error ("Invalid byte code in %s", SDATA (XCAR (tem)));
- else
- error ("Invalid byte code");
- }
-
- Lisp_Object bytecode = XCAR (tem);
- if (STRING_MULTIBYTE (bytecode))
- {
- /* BYTECODE must have been produced by Emacs 20.2 or earlier
- because it produced a raw 8-bit string for byte-code and now
- such a byte-code string is loaded as multibyte with raw 8-bit
- characters converted to multibyte form. Convert them back to
- the original unibyte form. */
- bytecode = Fstring_as_unibyte (bytecode);
- }
-
- pin_string (bytecode);
- ASET (object, COMPILED_BYTECODE, bytecode);
- ASET (object, COMPILED_CONSTANTS, XCDR (tem));
- }
- }
- return object;
-}
/* Return true if SYMBOL's default currently has a let-binding
which was made in the buffer that is now current. */
@@ -3529,7 +3475,7 @@ specbind (Lisp_Object symbol, Lisp_Object value)
switch (sym->u.s.redirect)
{
case SYMBOL_VARALIAS:
- sym = SYMBOL_ALIAS (sym); XSETSYMBOL (symbol, sym); goto start;
+ sym = SYMBOL_ALIAS (sym); symbol = make_lisp_symbol (sym); goto start;
case SYMBOL_PLAINVAL:
/* The most common case is that of a non-constant symbol with a
trivial value. Make that as fast as we can. */
@@ -4512,7 +4458,6 @@ alist of active lexical bindings. */);
defsubr (&Srun_hook_with_args_until_success);
defsubr (&Srun_hook_with_args_until_failure);
defsubr (&Srun_hook_wrapped);
- defsubr (&Sfetch_bytecode);
defsubr (&Sbacktrace_debug);
DEFSYM (QCdebug_on_exit, ":debug-on-exit");
defsubr (&Smapbacktrace);
diff --git a/src/fileio.c b/src/fileio.c
index a92da93ae48..483498fd879 100644
--- a/src/fileio.c
+++ b/src/fileio.c
@@ -5628,7 +5628,15 @@ write_region (Lisp_Object start, Lisp_Object end,
Lisp_Object filename,
changed to a call to `stat'. */
if (emacs_fstatat (AT_FDCWD, fn, &st1, 0) == 0
- && st.st_dev == st1.st_dev && st.st_ino == st1.st_ino)
+ && st.st_dev == st1.st_dev
+ && (st.st_ino == st1.st_ino
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* `st1.st_ino' == 0 indicates that the inode number
+ cannot be extracted from this document file, despite
+ `st' potentially being backed by a real file. */
+ || st1.st_ino == 0
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+ ))
{
/* Use the heuristic if it appears to be valid. With neither
O_EXCL nor O_TRUNC, if Emacs happened to write nothing to the
diff --git a/src/fns.c b/src/fns.c
index e4fa8157000..0a64e515402 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2782,13 +2782,8 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum
equal_kind equal_kind,
/* A symbol with position compares the contained symbol, and is
`equal' to the corresponding ordinary symbol. */
- if (symbols_with_pos_enabled)
- {
- if (SYMBOL_WITH_POS_P (o1))
- o1 = SYMBOL_WITH_POS_SYM (o1);
- if (SYMBOL_WITH_POS_P (o2))
- o2 = SYMBOL_WITH_POS_SYM (o2);
- }
+ o1 = maybe_remove_pos_from_symbol (o1);
+ o2 = maybe_remove_pos_from_symbol (o2);
if (BASE_EQ (o1, o2))
return true;
@@ -2869,11 +2864,14 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum
equal_kind equal_kind,
if (TS_NODEP (o1))
return treesit_node_eq (o1, o2);
#endif
- if (SYMBOL_WITH_POS_P(o1)) /* symbols_with_pos_enabled is false. */
- return (BASE_EQ (XSYMBOL_WITH_POS (o1)->sym,
- XSYMBOL_WITH_POS (o2)->sym)
- && BASE_EQ (XSYMBOL_WITH_POS (o1)->pos,
- XSYMBOL_WITH_POS (o2)->pos));
+ if (SYMBOL_WITH_POS_P (o1))
+ {
+ eassert (!symbols_with_pos_enabled);
+ return (BASE_EQ (XSYMBOL_WITH_POS_SYM (o1),
+ XSYMBOL_WITH_POS_SYM (o2))
+ && BASE_EQ (XSYMBOL_WITH_POS_POS (o1),
+ XSYMBOL_WITH_POS_POS (o2)));
+ }
/* Aside from them, only true vectors, char-tables, compiled
functions, and fonts (font-spec, font-entity, font-object)
@@ -3211,7 +3209,7 @@ SEQUENCE may be a list, a vector, a bool-vector, or a
string. */)
Lisp_Object
do_yes_or_no_p (Lisp_Object prompt)
{
- return call1 (intern ("yes-or-no-p"), prompt);
+ return call1 (Qyes_or_no_p, prompt);
}
DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
@@ -3256,7 +3254,7 @@ by a mouse, or by some window-system gesture, or via a
menu. */)
}
if (use_short_answers)
- return call1 (intern ("y-or-n-p"), prompt);
+ return call1 (Qy_or_n_p, prompt);
{
char *s = SSDATA (prompt);
@@ -4291,7 +4289,7 @@ set_hash_hash_slot (struct Lisp_Hash_Table *h, ptrdiff_t
idx, hash_hash_t val)
static void
set_hash_index_slot (struct Lisp_Hash_Table *h, ptrdiff_t idx, ptrdiff_t val)
{
- eassert (idx >= 0 && idx < h->index_size);
+ eassert (idx >= 0 && idx < hash_table_index_size (h));
h->index[idx] = val;
}
@@ -4392,7 +4390,7 @@ HASH_NEXT (struct Lisp_Hash_Table *h, ptrdiff_t idx)
static ptrdiff_t
HASH_INDEX (struct Lisp_Hash_Table *h, ptrdiff_t idx)
{
- eassert (idx >= 0 && idx < h->index_size);
+ eassert (idx >= 0 && idx < hash_table_index_size (h));
return h->index[idx];
}
@@ -4452,22 +4450,11 @@ cmpfn_user_defined (Lisp_Object key1, Lisp_Object key2,
return hash_table_user_defined_call (ARRAYELTS (args), args, h);
}
-/* Reduce an EMACS_UINT hash value to hash_hash_t. */
-static inline hash_hash_t
-reduce_emacs_uint_to_hash_hash (EMACS_UINT x)
-{
- verify (sizeof x <= 2 * sizeof (hash_hash_t));
- return (sizeof x == sizeof (hash_hash_t)
- ? x
- : x ^ (x >> (8 * (sizeof x - sizeof (hash_hash_t)))));
-}
-
static EMACS_INT
sxhash_eq (Lisp_Object key)
{
- if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (key))
- key = SYMBOL_WITH_POS_SYM (key);
- return XHASH (key) ^ XTYPE (key);
+ Lisp_Object k = maybe_remove_pos_from_symbol (key);
+ return XHASH (k) ^ XTYPE (k);
}
static EMACS_INT
@@ -4527,26 +4514,19 @@ allocate_hash_table (void)
return ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Hash_Table, PVEC_HASH_TABLE);
}
-/* Compute the size of the index from the table capacity. */
-static ptrdiff_t
-hash_index_size (ptrdiff_t size)
-{
- /* An upper bound on the size of a hash table index. It must fit in
- ptrdiff_t and be a valid Emacs fixnum. */
- ptrdiff_t upper_bound = min (MOST_POSITIVE_FIXNUM,
- min (TYPE_MAXIMUM (hash_idx_t),
- PTRDIFF_MAX / sizeof (ptrdiff_t)));
- /* Single-element index vectors are used iff size=0. */
- eassert (size > 0);
- ptrdiff_t lower_bound = 2;
- ptrdiff_t index_size = size + max (size >> 2, 1); /* 1.25x larger */
- if (index_size < upper_bound)
- index_size = (index_size < lower_bound
- ? lower_bound
- : next_almost_prime (index_size));
- if (index_size > upper_bound)
+/* Compute the size of the index (as log2) from the table capacity. */
+static int
+compute_hash_index_bits (hash_idx_t size)
+{
+ /* An upper bound on the size of a hash table index index. */
+ hash_idx_t upper_bound = min (MOST_POSITIVE_FIXNUM,
+ min (TYPE_MAXIMUM (hash_idx_t),
+ PTRDIFF_MAX / sizeof (hash_idx_t)));
+ /* Use next higher power of 2. This works even for size=0. */
+ int bits = elogb (size) + 1;
+ if (bits >= TYPE_WIDTH (uintmax_t) || ((uintmax_t)1 << bits) > upper_bound)
error ("Hash table too large");
- return index_size;
+ return bits;
}
/* Constant hash index vector used when the table size is zero.
@@ -4587,7 +4567,7 @@ make_hash_table (const struct hash_table_test *test,
EMACS_INT size,
h->key_and_value = NULL;
h->hash = NULL;
h->next = NULL;
- h->index_size = 1;
+ h->index_bits = 0;
h->index = (hash_idx_t *)empty_hash_index_vector;
h->next_free = -1;
}
@@ -4605,8 +4585,9 @@ make_hash_table (const struct hash_table_test *test,
EMACS_INT size,
h->next[i] = i + 1;
h->next[size - 1] = -1;
- int index_size = hash_index_size (size);
- h->index_size = index_size;
+ int index_bits = compute_hash_index_bits (size);
+ h->index_bits = index_bits;
+ ptrdiff_t index_size = hash_table_index_size (h);
h->index = hash_table_alloc_bytes (index_size * sizeof *h->index);
for (ptrdiff_t i = 0; i < index_size; i++)
h->index[i] = -1;
@@ -4617,13 +4598,7 @@ make_hash_table (const struct hash_table_test *test,
EMACS_INT size,
h->next_weak = NULL;
h->purecopy = purecopy;
h->mutable = true;
-
- Lisp_Object table;
- XSET_HASH_TABLE (table, h);
- eassert (HASH_TABLE_P (table));
- eassert (XHASH_TABLE (table) == h);
-
- return table;
+ return make_lisp_hash_table (h);
}
@@ -4633,7 +4608,6 @@ make_hash_table (const struct hash_table_test *test,
EMACS_INT size,
static Lisp_Object
copy_hash_table (struct Lisp_Hash_Table *h1)
{
- Lisp_Object table;
struct Lisp_Hash_Table *h2;
h2 = allocate_hash_table ();
@@ -4654,22 +4628,18 @@ copy_hash_table (struct Lisp_Hash_Table *h1)
h2->next = hash_table_alloc_bytes (next_bytes);
memcpy (h2->next, h1->next, next_bytes);
- ptrdiff_t index_bytes = h1->index_size * sizeof *h1->index;
+ ptrdiff_t index_bytes = hash_table_index_size (h1) * sizeof *h1->index;
h2->index = hash_table_alloc_bytes (index_bytes);
memcpy (h2->index, h1->index, index_bytes);
}
- XSET_HASH_TABLE (table, h2);
-
- return table;
+ return make_lisp_hash_table (h2);
}
-
/* Compute index into the index vector from a hash value. */
static inline ptrdiff_t
hash_index_index (struct Lisp_Hash_Table *h, hash_hash_t hash)
{
- eassert (h->index_size > 0);
- return hash % h->index_size;
+ return knuth_hash (hash, h->index_bits);
}
/* Resize hash table H if it's too full. If H cannot be resized
@@ -4681,7 +4651,7 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
if (h->next_free < 0)
{
ptrdiff_t old_size = HASH_TABLE_SIZE (h);
- ptrdiff_t min_size = 8;
+ ptrdiff_t min_size = 6;
ptrdiff_t base_size = min (max (old_size, min_size), PTRDIFF_MAX / 2);
/* Grow aggressively at small sizes, then just double. */
ptrdiff_t new_size =
@@ -4706,13 +4676,14 @@ maybe_resize_hash_table (struct Lisp_Hash_Table *h)
hash_hash_t *hash = hash_table_alloc_bytes (new_size * sizeof *hash);
memcpy (hash, h->hash, old_size * sizeof *hash);
- ptrdiff_t old_index_size = h->index_size;
- ptrdiff_t index_size = hash_index_size (new_size);
+ ptrdiff_t old_index_size = hash_table_index_size (h);
+ ptrdiff_t index_bits = compute_hash_index_bits (new_size);
+ ptrdiff_t index_size = (ptrdiff_t)1 << index_bits;
hash_idx_t *index = hash_table_alloc_bytes (index_size * sizeof *index);
for (ptrdiff_t i = 0; i < index_size; i++)
index[i] = -1;
- h->index_size = index_size;
+ h->index_bits = index_bits;
h->table_size = new_size;
h->next_free = old_size;
@@ -4778,18 +4749,19 @@ hash_table_thaw (Lisp_Object hash_table)
h->key_and_value = NULL;
h->hash = NULL;
h->next = NULL;
- h->index_size = 1;
+ h->index_bits = 0;
h->index = (hash_idx_t *)empty_hash_index_vector;
}
else
{
- ptrdiff_t index_size = hash_index_size (size);
- h->index_size = index_size;
+ ptrdiff_t index_bits = compute_hash_index_bits (size);
+ h->index_bits = index_bits;
h->hash = hash_table_alloc_bytes (size * sizeof *h->hash);
h->next = hash_table_alloc_bytes (size * sizeof *h->next);
+ ptrdiff_t index_size = hash_table_index_size (h);
h->index = hash_table_alloc_bytes (index_size * sizeof *h->index);
for (ptrdiff_t i = 0; i < index_size; i++)
h->index[i] = -1;
@@ -4937,7 +4909,8 @@ hash_clear (struct Lisp_Hash_Table *h)
set_hash_value_slot (h, i, Qnil);
}
- for (ptrdiff_t i = 0; i < h->index_size; i++)
+ ptrdiff_t index_size = hash_table_index_size (h);
+ for (ptrdiff_t i = 0; i < index_size; i++)
h->index[i] = -1;
h->next_free = 0;
@@ -4976,7 +4949,7 @@ keep_entry_p (hash_table_weakness_t weakness,
bool
sweep_weak_table (struct Lisp_Hash_Table *h, bool remove_entries_p)
{
- ptrdiff_t n = h->index_size;
+ ptrdiff_t n = hash_table_index_size (h);
bool marked = false;
for (ptrdiff_t bucket = 0; bucket < n; ++bucket)
@@ -5072,24 +5045,52 @@ hash_string (char const *ptr, ptrdiff_t len)
EMACS_UINT hash = len;
/* At most 8 steps. We could reuse SXHASH_MAX_LEN, of course,
* but dividing by 8 is cheaper. */
- ptrdiff_t step = sizeof hash + ((end - p) >> 3);
+ ptrdiff_t step = max (sizeof hash, ((end - p) >> 3));
- while (p + sizeof hash <= end)
+ if (p + sizeof hash <= end)
{
+ do
+ {
+ EMACS_UINT c;
+ /* We presume that the compiler will replace this `memcpy` with
+ a single load/move instruction when applicable. */
+ memcpy (&c, p, sizeof hash);
+ p += step;
+ hash = sxhash_combine (hash, c);
+ }
+ while (p + sizeof hash <= end);
+ /* Hash the last wordful of bytes in the string, because that is
+ is often the part where strings differ. This may cause some
+ bytes to be hashed twice but we assume that's not a big problem. */
EMACS_UINT c;
- /* We presume that the compiler will replace this `memcpy` with
- a single load/move instruction when applicable. */
- memcpy (&c, p, sizeof hash);
- p += step;
+ memcpy (&c, end - sizeof c, sizeof c);
hash = sxhash_combine (hash, c);
}
- /* A few last bytes may remain (smaller than an EMACS_UINT). */
- /* FIXME: We could do this without a loop, but it'd require
- endian-dependent code :-( */
- while (p < end)
+ else
{
- unsigned char c = *p++;
- hash = sxhash_combine (hash, c);
+ /* String is shorter than an EMACS_UINT. Use smaller loads. */
+ eassume (p <= end && end - p < sizeof (EMACS_UINT));
+ EMACS_UINT tail = 0;
+ verify (sizeof tail <= 8);
+#if EMACS_INT_MAX > INT32_MAX
+ if (end - p >= 4)
+ {
+ uint32_t c;
+ memcpy (&c, p, sizeof c);
+ tail = (tail << (8 * sizeof c)) + c;
+ p += sizeof c;
+ }
+#endif
+ if (end - p >= 2)
+ {
+ uint16_t c;
+ memcpy (&c, p, sizeof c);
+ tail = (tail << (8 * sizeof c)) + c;
+ p += sizeof c;
+ }
+ if (p < end)
+ tail = (tail << 8) + (unsigned char)*p;
+ hash = sxhash_combine (hash, tail);
}
return hash;
@@ -5177,7 +5178,7 @@ sxhash_bignum (Lisp_Object bignum)
{
mpz_t const *n = xbignum_val (bignum);
size_t i, nlimbs = mpz_size (*n);
- EMACS_UINT hash = 0;
+ EMACS_UINT hash = mpz_sgn(*n) < 0;
for (i = 0; i < nlimbs; ++i)
hash = sxhash_combine (hash, mpz_getlimbn (*n, i));
@@ -5247,12 +5248,15 @@ sxhash_obj (Lisp_Object obj, int depth)
hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist,
depth));
return hash;
}
- else if (symbols_with_pos_enabled && pvec_type == PVEC_SYMBOL_WITH_POS)
- return sxhash_obj (XSYMBOL_WITH_POS (obj)->sym, depth + 1);
else
- /* Others are 'equal' if they are 'eq', so take their
- address as hash. */
- return XHASH (obj);
+ {
+ if (symbols_with_pos_enabled && pvec_type == PVEC_SYMBOL_WITH_POS)
+ obj = XSYMBOL_WITH_POS_SYM (obj);
+
+ /* Others are 'equal' if they are 'eq', so take their
+ address as hash. */
+ return XHASH (obj);
+ }
}
case Lisp_Cons:
@@ -5374,6 +5378,8 @@ mark_fns (void)
}
}
+/* Find the hash_table_test object corresponding to the (bare) symbol TEST,
+ creating one if none existed. */
static struct hash_table_test *
get_hash_table_user_test (Lisp_Object test)
{
@@ -5384,7 +5390,8 @@ get_hash_table_user_test (Lisp_Object test)
Lisp_Object equal_fn = XCAR (prop);
Lisp_Object hash_fn = XCAR (XCDR (prop));
struct hash_table_user_test *ut = hash_table_user_tests;
- while (ut && !(EQ (equal_fn, ut->test.user_cmp_function)
+ while (ut && !(BASE_EQ (test, ut->test.name)
+ && EQ (equal_fn, ut->test.user_cmp_function)
&& EQ (hash_fn, ut->test.user_hash_function)))
ut = ut->next;
if (!ut)
@@ -5444,9 +5451,7 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */)
/* See if there's a `:test TEST' among the arguments. */
ptrdiff_t i = get_key_arg (QCtest, nargs, args, used);
- Lisp_Object test = i ? args[i] : Qeql;
- if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (test))
- test = SYMBOL_WITH_POS_SYM (test);
+ Lisp_Object test = i ? maybe_remove_pos_from_symbol (args[i]) : Qeql;
const struct hash_table_test *testdesc;
if (BASE_EQ (test, Qeq))
testdesc = &hashtest_eq;
@@ -5698,7 +5703,7 @@ DEFUN ("internal--hash-table-histogram",
struct Lisp_Hash_Table *h = check_hash_table (hash_table);
ptrdiff_t size = HASH_TABLE_SIZE (h);
ptrdiff_t *freq = xzalloc (size * sizeof *freq);
- ptrdiff_t index_size = h->index_size;
+ ptrdiff_t index_size = hash_table_index_size (h);
for (ptrdiff_t i = 0; i < index_size; i++)
{
ptrdiff_t n = 0;
@@ -5726,7 +5731,7 @@ Internal use only. */)
{
struct Lisp_Hash_Table *h = check_hash_table (hash_table);
Lisp_Object ret = Qnil;
- ptrdiff_t index_size = h->index_size;
+ ptrdiff_t index_size = hash_table_index_size (h);
for (ptrdiff_t i = 0; i < index_size; i++)
{
Lisp_Object bucket = Qnil;
@@ -5747,7 +5752,7 @@ DEFUN ("internal--hash-table-index-size",
(Lisp_Object hash_table)
{
struct Lisp_Hash_Table *h = check_hash_table (hash_table);
- return make_int (h->index_size);
+ return make_int (hash_table_index_size (h));
}
@@ -6615,4 +6620,6 @@ For best results this should end in a space. */);
DEFSYM (Qreal_this_command, "real-this-command");
DEFSYM (Qfrom__tty_menu_p, "from--tty-menu-p");
+ DEFSYM (Qyes_or_no_p, "yes-or-no-p");
+ DEFSYM (Qy_or_n_p, "y-or-n-p");
}
diff --git a/src/inotify.c b/src/inotify.c
index 2ee874530cc..7140568f1b6 100644
--- a/src/inotify.c
+++ b/src/inotify.c
@@ -26,6 +26,8 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include "termhooks.h"
#include <errno.h>
+#include <fcntl.h>
+
#include <sys/inotify.h>
#include <sys/ioctl.h>
@@ -434,7 +436,15 @@ IN_ONESHOT */)
if (inotifyfd < 0)
{
+#ifdef HAVE_INOTIFY_INIT1
inotifyfd = inotify_init1 (IN_NONBLOCK | IN_CLOEXEC);
+#else /* !HAVE_INOTIFY_INIT1 */
+ /* This is prey to race conditions with other threads calling
+ exec. */
+ inotifyfd = inotify_init ();
+ fcntl (inotifyfd, F_SETFL, O_NONBLOCK);
+ fcntl (inotifyfd, F_SETFD, O_CLOEXEC);
+#endif /* HAVE_INOTIFY_INIT1 */
if (inotifyfd < 0)
report_file_notify_error ("File watching is not available", Qnil);
watch_list = Qnil;
diff --git a/src/keyboard.c b/src/keyboard.c
index 1f7253a7da1..eb0de98bad1 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -580,7 +580,10 @@ echo_dash (void)
idx = make_fixnum (SCHARS (KVAR (current_kboard, echo_string)) - 1);
last_char = Faref (KVAR (current_kboard, echo_string), idx);
- if (XFIXNUM (last_char) == '-' && XFIXNUM (prev_char) != ' ')
+ if ((XFIXNUM (last_char) == '-' && XFIXNUM (prev_char) != ' ')
+ /* Or a keystroke help message. */
+ || (echo_keystrokes_help
+ && XFIXNUM (last_char) == ')' && XFIXNUM (prev_char) == 'p'))
return;
}
@@ -589,6 +592,12 @@ echo_dash (void)
AUTO_STRING (dash, "-");
kset_echo_string (current_kboard,
concat2 (KVAR (current_kboard, echo_string), dash));
+
+ if (echo_keystrokes_help)
+ kset_echo_string (current_kboard,
+ calln (Qhelp__append_keystrokes_help,
+ KVAR (current_kboard, echo_string)));
+
echo_now ();
}
@@ -1067,8 +1076,9 @@ Default value of `command-error-function'. */)
write to stderr and quit. In daemon mode, there are
many other potential errors that do not prevent frames
from being created, so continuing as normal is better in
- that case. */
- || (!IS_DAEMON && FRAME_INITIAL_P (sf))
+ that case, as long as the daemon has actually finished
+ initialization. */
+ || (!(IS_DAEMON && !DAEMON_RUNNING) && FRAME_INITIAL_P (sf))
|| noninteractive))
{
print_error_message (data, Qexternal_debugging_output,
@@ -12948,6 +12958,8 @@ syms_of_keyboard (void)
DEFSYM (Qhelp_key_binding, "help-key-binding");
+ DEFSYM (Qhelp__append_keystrokes_help, "help--append-keystrokes-help");
+
DEFSYM (Qecho_keystrokes, "echo-keystrokes");
Fset (Qinput_method_exit_on_first_char, Qnil);
@@ -13223,11 +13235,17 @@ Emacs also does a garbage collection if that seems to
be warranted. */);
XSETFASTINT (Vauto_save_timeout, 30);
DEFVAR_LISP ("echo-keystrokes", Vecho_keystrokes,
- doc: /* Nonzero means echo unfinished commands after this many
seconds of pause.
+ doc: /* Nonzero means echo unfinished commands after this many seconds of
pause.
The value may be integer or floating point.
If the value is zero, don't echo at all. */);
Vecho_keystrokes = make_fixnum (1);
+ DEFVAR_BOOL ("echo-keystrokes-help", echo_keystrokes_help,
+ doc: /* Whether to append help text to echoed commands.
+When non-nil, a reference to `C-h' is printed after echoed
+keystrokes. */);
+ echo_keystrokes_help = true;
+
DEFVAR_LISP ("polling-period", Vpolling_period,
doc: /* Interval between polling for input during Lisp execution.
The reason for polling is to make C-g work to stop a running program.
diff --git a/src/lisp.h b/src/lisp.h
index 75134425a07..4fc44745211 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -330,7 +330,8 @@ typedef EMACS_INT Lisp_Word;
without worrying about the implementations diverging, since
lisp_h_OP defines the actual implementation. The lisp_h_OP macros
are intended to be private to this include file, and should not be
- used elsewhere.
+ used elsewhere. They should evaluate each argument exactly once,
+ so that they behave like their functional counterparts.
FIXME: Remove the lisp_h_OP macros, and define just the inline OP
functions, once "gcc -Og" (new to GCC 4.8) or equivalent works well
@@ -372,39 +373,12 @@ typedef EMACS_INT Lisp_Word;
# define lisp_h_Qnil {0}
#endif
-#define lisp_h_PSEUDOVECTORP(a,code) \
- (lisp_h_VECTORLIKEP (a) \
- && ((XUNTAG (a, Lisp_Vectorlike, union vectorlike_header)->size \
- & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \
- == (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS))))
-
#define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x)
#define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
#define lisp_h_CHECK_TYPE(ok, predicate, x) \
((ok) ? (void) 0 : wrong_type_argument (predicate, x))
#define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons)
#define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y))
-#define lisp_h_BASE2_EQ(x, y) \
- (BASE_EQ (x, y) \
- || (symbols_with_pos_enabled \
- && SYMBOL_WITH_POS_P (x) \
- && BASE_EQ (XSYMBOL_WITH_POS (x)->sym, y)))
-
-/* FIXME: Do we really need to inline the whole thing?
- * What about keeping the part after `symbols_with_pos_enabled` in
- * a separate function? */
-#define lisp_h_EQ(x, y) \
- (XLI (x) == XLI (y) \
- || (symbols_with_pos_enabled \
- && (SYMBOL_WITH_POS_P (x) \
- ? (BARE_SYMBOL_P (y) \
- ? XLI (XSYMBOL_WITH_POS (x)->sym) == XLI (y) \
- : (SYMBOL_WITH_POS_P (y) \
- && (XLI (XSYMBOL_WITH_POS (x)->sym) \
- == XLI (XSYMBOL_WITH_POS (y)->sym)))) \
- : (SYMBOL_WITH_POS_P (y) \
- && BARE_SYMBOL_P (x) \
- && (XLI (x) == XLI (XSYMBOL_WITH_POS (y)->sym))))))
#define lisp_h_FIXNUMP(x) \
(! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
@@ -412,18 +386,11 @@ typedef EMACS_INT Lisp_Word;
& ((1 << INTTYPEBITS) - 1)))
#define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float)
#define lisp_h_NILP(x) BASE_EQ (x, Qnil)
-#define lisp_h_SET_SYMBOL_VAL(sym, v) \
- (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \
- (sym)->u.s.val.value = (v))
#define lisp_h_SYMBOL_CONSTANT_P(sym) \
(XSYMBOL (sym)->u.s.trapped_write == SYMBOL_NOWRITE)
#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write)
-#define lisp_h_SYMBOL_VAL(sym) \
- (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value)
#define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP (x, PVEC_SYMBOL_WITH_POS)
#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP (x, Lisp_Symbol)
-#define lisp_h_SYMBOLP(x) \
- (BARE_SYMBOL_P (x) || (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)))
#define lisp_h_TAGGEDP(a, tag) \
(! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
- (unsigned) (tag)) \
@@ -431,8 +398,6 @@ typedef EMACS_INT Lisp_Word;
#define lisp_h_VECTORLIKEP(x) TAGGEDP (x, Lisp_Vectorlike)
#define lisp_h_XCAR(c) XCONS (c)->u.s.car
#define lisp_h_XCDR(c) XCONS (c)->u.s.u.cdr
-#define lisp_h_XCONS(a) \
- (eassert (CONSP (a)), XUNTAG (a, Lisp_Cons, struct Lisp_Cons))
#define lisp_h_XHASH(a) XUFIXNUM_RAW (a)
#if USE_LSB_TAG
# define lisp_h_make_fixnum_wrap(n) \
@@ -474,20 +439,15 @@ typedef EMACS_INT Lisp_Word;
# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x)
# define CONSP(x) lisp_h_CONSP (x)
# define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y)
-# define BASE2_EQ(x, y) lisp_h_BASE2_EQ (x, y)
# define FLOATP(x) lisp_h_FLOATP (x)
# define FIXNUMP(x) lisp_h_FIXNUMP (x)
# define NILP(x) lisp_h_NILP (x)
-# define SET_SYMBOL_VAL(sym, v) lisp_h_SET_SYMBOL_VAL (sym, v)
# define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym)
# define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym)
-# define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym)
-/* # define SYMBOLP(x) lisp_h_SYMBOLP (x) */ /* X is accessed more than once.
*/
# define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag)
# define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
# define XCAR(c) lisp_h_XCAR (c)
# define XCDR(c) lisp_h_XCDR (c)
-# define XCONS(a) lisp_h_XCONS (a)
# define XHASH(a) lisp_h_XHASH (a)
# if USE_LSB_TAG
# define make_fixnum(n) lisp_h_make_fixnum (n)
@@ -518,6 +478,16 @@ typedef EMACS_INT Lisp_Word;
#endif
+/* Lisp_Object tagging scheme:
+ Tag location
+ Upper bits Lower bits Type Payload
+ 000....... .......000 symbol offset from lispsym to struct
Lisp_Symbol
+ 001....... .......001 unused
+ 01........ ........10 fixnum signed integer of FIXNUM_BITS
+ 110....... .......011 cons pointer to struct Lisp_Cons
+ 100....... .......100 string pointer to struct Lisp_String
+ 101....... .......101 vectorlike pointer to union vectorlike_header
+ 111....... .......111 float pointer to struct Lisp_Float */
enum Lisp_Type
{
/* Symbol. XSYMBOL (object) points to a struct Lisp_Symbol. */
@@ -1062,6 +1032,7 @@ enum pvec_type
PVEC_BOOL_VECTOR,
PVEC_BUFFER,
PVEC_HASH_TABLE,
+ PVEC_OBARRAY,
PVEC_TERMINAL,
PVEC_WINDOW_CONFIGURATION,
PVEC_SUBR,
@@ -1121,7 +1092,10 @@ enum More_Lisp_Bits
INLINE bool
PSEUDOVECTORP (Lisp_Object a, int code)
{
- return lisp_h_PSEUDOVECTORP (a, code);
+ return (lisp_h_VECTORLIKEP (a)
+ && ((XUNTAG (a, Lisp_Vectorlike, union vectorlike_header)->size
+ & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK))
+ == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))));
}
INLINE bool
@@ -1137,9 +1111,10 @@ INLINE bool
}
INLINE bool
-(SYMBOLP) (Lisp_Object x)
+SYMBOLP (Lisp_Object x)
{
- return lisp_h_SYMBOLP (x);
+ return (BARE_SYMBOL_P (x)
+ || (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)));
}
INLINE struct Lisp_Symbol_With_Pos *
@@ -1149,6 +1124,27 @@ XSYMBOL_WITH_POS (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
}
+INLINE Lisp_Object
+XSYMBOL_WITH_POS_SYM (Lisp_Object a)
+{
+ Lisp_Object sym = XSYMBOL_WITH_POS (a)->sym;
+ eassume (BARE_SYMBOL_P (sym));
+ return sym;
+}
+
+INLINE Lisp_Object
+XSYMBOL_WITH_POS_POS (Lisp_Object a)
+{
+ return XSYMBOL_WITH_POS (a)->pos;
+}
+
+INLINE Lisp_Object
+maybe_remove_pos_from_symbol (Lisp_Object x)
+{
+ return (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)
+ ? XSYMBOL_WITH_POS_SYM (x) : x);
+}
+
INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
XBARE_SYMBOL (Lisp_Object a)
{
@@ -1163,8 +1159,8 @@ XSYMBOL (Lisp_Object a)
{
if (!BARE_SYMBOL_P (a))
{
- eassert (symbols_with_pos_enabled);
- a = XSYMBOL_WITH_POS (a)->sym;
+ eassume (symbols_with_pos_enabled);
+ a = XSYMBOL_WITH_POS_SYM (a);
}
return XBARE_SYMBOL (a);
}
@@ -1352,20 +1348,15 @@ INLINE bool
return lisp_h_BASE_EQ (x, y);
}
-/* Return true if X and Y are the same object, reckoning X to be the
- same as a bare symbol Y if X is Y with position. */
-INLINE bool
-(BASE2_EQ) (Lisp_Object x, Lisp_Object y)
-{
- return lisp_h_BASE2_EQ (x, y);
-}
-
/* Return true if X and Y are the same object, reckoning a symbol with
position as being the same as the bare symbol. */
INLINE bool
-(EQ) (Lisp_Object x, Lisp_Object y)
+EQ (Lisp_Object x, Lisp_Object y)
{
- return lisp_h_EQ (x, y);
+ return BASE_EQ ((symbols_with_pos_enabled && SYMBOL_WITH_POS_P (x)
+ ? XSYMBOL_WITH_POS_SYM (x) : x),
+ (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (y)
+ ? XSYMBOL_WITH_POS_SYM (y) : y));
}
INLINE intmax_t
@@ -1389,7 +1380,6 @@ make_lisp_ptr (void *ptr, enum Lisp_Type type)
#define XSETCONS(a, b) ((a) = make_lisp_ptr (b, Lisp_Cons))
#define XSETVECTOR(a, b) ((a) = make_lisp_ptr (b, Lisp_Vectorlike))
#define XSETSTRING(a, b) ((a) = make_lisp_ptr (b, Lisp_String))
-#define XSETSYMBOL(a, b) ((a) = make_lisp_symbol (b))
#define XSETFLOAT(a, b) ((a) = make_lisp_ptr (b, Lisp_Float))
/* Return a Lisp_Object value that does not correspond to any object.
@@ -1510,9 +1500,10 @@ CHECK_CONS (Lisp_Object x)
}
INLINE struct Lisp_Cons *
-(XCONS) (Lisp_Object a)
+XCONS (Lisp_Object a)
{
- return lisp_h_XCONS (a);
+ eassert (CONSP (a));
+ return XUNTAG (a, Lisp_Cons, struct Lisp_Cons);
}
/* Take the car or cdr of something known to be a cons cell. */
@@ -2297,9 +2288,10 @@ typedef jmp_buf sys_jmp_buf;
/* Value is name of symbol. */
INLINE Lisp_Object
-(SYMBOL_VAL) (struct Lisp_Symbol *sym)
+SYMBOL_VAL (struct Lisp_Symbol *sym)
{
- return lisp_h_SYMBOL_VAL (sym);
+ eassert (sym->u.s.redirect == SYMBOL_PLAINVAL);
+ return sym->u.s.val.value;
}
INLINE struct Lisp_Symbol *
@@ -2322,9 +2314,10 @@ SYMBOL_FWD (struct Lisp_Symbol *sym)
}
INLINE void
-(SET_SYMBOL_VAL) (struct Lisp_Symbol *sym, Lisp_Object v)
+SET_SYMBOL_VAL (struct Lisp_Symbol *sym, Lisp_Object v)
{
- lisp_h_SET_SYMBOL_VAL (sym, v);
+ eassert (sym->u.s.redirect == SYMBOL_PLAINVAL);
+ sym->u.s.val.value = v;
}
INLINE void
@@ -2393,6 +2386,118 @@ INLINE int
definition is done by lread.c's define_symbol. */
#define DEFSYM(sym, name) /* empty */
+
+struct Lisp_Obarray
+{
+ union vectorlike_header header;
+
+ /* Array of 2**size_bits values, each being either a (bare) symbol or
+ the fixnum 0. The symbols for each bucket are chained via
+ their s.next field. */
+ Lisp_Object *buckets;
+
+ unsigned size_bits; /* log2(size of buckets vector) */
+ unsigned count; /* number of symbols in obarray */
+};
+
+INLINE bool
+OBARRAYP (Lisp_Object a)
+{
+ return PSEUDOVECTORP (a, PVEC_OBARRAY);
+}
+
+INLINE struct Lisp_Obarray *
+XOBARRAY (Lisp_Object a)
+{
+ eassert (OBARRAYP (a));
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Obarray);
+}
+
+INLINE void
+CHECK_OBARRAY (Lisp_Object x)
+{
+ CHECK_TYPE (OBARRAYP (x), Qobarrayp, x);
+}
+
+INLINE Lisp_Object
+make_lisp_obarray (struct Lisp_Obarray *o)
+{
+ eassert (PSEUDOVECTOR_TYPEP (&o->header, PVEC_OBARRAY));
+ return make_lisp_ptr (o, Lisp_Vectorlike);
+}
+
+INLINE ptrdiff_t
+obarray_size (const struct Lisp_Obarray *o)
+{
+ return (ptrdiff_t)1 << o->size_bits;
+}
+
+Lisp_Object check_obarray_slow (Lisp_Object);
+
+/* Return an obarray object from OBARRAY or signal an error. */
+INLINE Lisp_Object
+check_obarray (Lisp_Object obarray)
+{
+ return OBARRAYP (obarray) ? obarray : check_obarray_slow (obarray);
+}
+
+/* Obarray iterator state. Don't access these members directly.
+ The iterator functions must be called in the order followed by DOOBARRAY.
*/
+typedef struct {
+ struct Lisp_Obarray *o;
+ ptrdiff_t idx; /* Current bucket index. */
+ struct Lisp_Symbol *symbol; /* Current symbol, or NULL if at end
+ of current bucket. */
+} obarray_iter_t;
+
+INLINE obarray_iter_t
+make_obarray_iter (struct Lisp_Obarray *oa)
+{
+ return (obarray_iter_t){.o = oa, .idx = -1, .symbol = NULL};
+}
+
+/* Whether IT has reached the end and there are no more symbols.
+ If true, IT is dead and cannot be used any more. */
+INLINE bool
+obarray_iter_at_end (obarray_iter_t *it)
+{
+ if (it->symbol)
+ return false;
+ ptrdiff_t size = obarray_size (it->o);
+ while (++it->idx < size)
+ {
+ Lisp_Object obj = it->o->buckets[it->idx];
+ if (!BASE_EQ (obj, make_fixnum (0)))
+ {
+ it->symbol = XBARE_SYMBOL (obj);
+ return false;
+ }
+ }
+ return true;
+}
+
+/* Advance IT to the next symbol if any. */
+INLINE void
+obarray_iter_step (obarray_iter_t *it)
+{
+ it->symbol = it->symbol->u.s.next;
+}
+
+/* The Lisp symbol at IT, if obarray_iter_at_end returned false. */
+INLINE Lisp_Object
+obarray_iter_symbol (obarray_iter_t *it)
+{
+ return make_lisp_symbol (it->symbol);
+}
+
+/* Iterate IT over the symbols of the obarray OA.
+ The body shouldn't add or remove symbols in OA, but disobeying that rule
+ only risks symbols to be iterated more than once or not at all,
+ not crashes or data corruption. */
+#define DOOBARRAY(oa, it) \
+ for (obarray_iter_t it = make_obarray_iter (oa); \
+ !obarray_iter_at_end (&it); obarray_iter_step (&it))
+
/***********************************************************************
Hash Tables
@@ -2475,14 +2580,11 @@ struct Lisp_Hash_Table
The table is physically split into three vectors (hash, next,
key_and_value) which may or may not be beneficial. */
- hash_idx_t index_size; /* Size of the index vector. */
- hash_idx_t table_size; /* Size of the next and hash vectors. */
-
/* Bucket vector. An entry of -1 indicates no item is present,
and a nonnegative entry is the index of the first item in
a collision chain.
- This vector is index_size entries long.
- If index_size is 1 (and table_size is 0), then this is the
+ This vector is 2**index_bits entries long.
+ If index_bits is 0 (and table_size is 0), then this is the
constant read-only vector {-1}, shared between all instances.
Otherwise it is heap-allocated. */
hash_idx_t *index;
@@ -2514,20 +2616,24 @@ struct Lisp_Hash_Table
/* Index of first free entry in free list, or -1 if none. */
hash_idx_t next_free;
+ hash_idx_t table_size; /* Size of the next and hash vectors. */
+
+ unsigned char index_bits; /* log2 (size of the index vector). */
+
/* Weakness of the table. */
- hash_table_weakness_t weakness : 8;
+ hash_table_weakness_t weakness : 3;
/* Hash table test (only used when frozen in dump) */
- hash_table_std_test_t frozen_test : 8;
+ hash_table_std_test_t frozen_test : 2;
/* True if the table can be purecopied. The table cannot be
changed afterwards. */
- bool purecopy;
+ bool_bf purecopy : 1;
/* True if the table is mutable. Ordinarily tables are mutable, but
pure tables are not, and while a table is being mutated it is
immutable for recursive attempts to mutate it. */
- bool mutable;
+ bool_bf mutable : 1;
/* Next weak hash table if this is a weak hash table. The head of
the list is in weak_hash_tables. Used only during garbage
@@ -2563,8 +2669,12 @@ XHASH_TABLE (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Hash_Table);
}
-#define XSET_HASH_TABLE(VAR, PTR) \
- XSETPSEUDOVECTOR (VAR, PTR, PVEC_HASH_TABLE)
+INLINE Lisp_Object
+make_lisp_hash_table (struct Lisp_Hash_Table *h)
+{
+ eassert (PSEUDOVECTOR_TYPEP (&h->header, PVEC_HASH_TABLE));
+ return make_lisp_ptr (h, Lisp_Vectorlike);
+}
/* Value is the key part of entry IDX in hash table H. */
INLINE Lisp_Object
@@ -2597,6 +2707,13 @@ HASH_TABLE_SIZE (const struct Lisp_Hash_Table *h)
return h->table_size;
}
+/* Size of the index vector in hash table H. */
+INLINE ptrdiff_t
+hash_table_index_size (const struct Lisp_Hash_Table *h)
+{
+ return (ptrdiff_t)1 << h->index_bits;
+}
+
/* Hash value for KEY in hash table H. */
INLINE hash_hash_t
hash_from_key (struct Lisp_Hash_Table *h, Lisp_Object key)
@@ -2661,6 +2778,28 @@ SXHASH_REDUCE (EMACS_UINT x)
return (x ^ x >> (EMACS_INT_WIDTH - FIXNUM_BITS)) & INTMASK;
}
+/* Reduce an EMACS_UINT hash value to hash_hash_t. */
+INLINE hash_hash_t
+reduce_emacs_uint_to_hash_hash (EMACS_UINT x)
+{
+ verify (sizeof x <= 2 * sizeof (hash_hash_t));
+ return (sizeof x == sizeof (hash_hash_t)
+ ? x
+ : x ^ (x >> (8 * (sizeof x - sizeof (hash_hash_t)))));
+}
+
+/* Reduce HASH to a value BITS wide. */
+INLINE ptrdiff_t
+knuth_hash (hash_hash_t hash, unsigned bits)
+{
+ /* Knuth multiplicative hashing, tailored for 32-bit indices
+ (avoiding a 64-bit multiply). */
+ uint32_t alpha = 2654435769; /* 2**32/phi */
+ /* Note the cast to uint64_t, to make it work for bits=0. */
+ return (uint64_t)((uint32_t)hash * alpha) >> (32 - bits);
+}
+
+
struct Lisp_Marker
{
union vectorlike_header header;
@@ -2839,22 +2978,6 @@ XOVERLAY (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
}
-INLINE Lisp_Object
-SYMBOL_WITH_POS_SYM (Lisp_Object a)
-{
- if (!SYMBOL_WITH_POS_P (a))
- wrong_type_argument (Qsymbol_with_pos_p, a);
- return XSYMBOL_WITH_POS (a)->sym;
-}
-
-INLINE Lisp_Object
-SYMBOL_WITH_POS_POS (Lisp_Object a)
-{
- if (!SYMBOL_WITH_POS_P (a))
- wrong_type_argument (Qsymbol_with_pos_p, a);
- return XSYMBOL_WITH_POS (a)->pos;
-}
-
INLINE bool
USER_PTRP (Lisp_Object x)
{
@@ -4596,7 +4719,6 @@ extern ptrdiff_t evxprintf (char **, ptrdiff_t *, char *,
ptrdiff_t,
ATTRIBUTE_FORMAT_PRINTF (5, 0);
/* Defined in lread.c. */
-extern Lisp_Object check_obarray (Lisp_Object);
extern Lisp_Object intern_1 (const char *, ptrdiff_t);
extern Lisp_Object intern_c_string_1 (const char *, ptrdiff_t);
extern Lisp_Object intern_driver (Lisp_Object, Lisp_Object, Lisp_Object);
@@ -4802,7 +4924,7 @@ extern void syms_of_editfns (void);
/* Defined in buffer.c. */
extern bool mouse_face_overlay_overlaps (Lisp_Object);
-extern Lisp_Object disable_line_numbers_overlay_at_eob (void);
+extern bool disable_line_numbers_overlay_at_eob (void);
extern AVOID nsberror (Lisp_Object);
extern void adjust_overlays_for_insert (ptrdiff_t, ptrdiff_t, bool);
extern void adjust_overlays_for_delete (ptrdiff_t, ptrdiff_t);
@@ -5030,6 +5152,7 @@ extern bool build_details;
/* 0 not a daemon, 1 foreground daemon, 2 background daemon. */
extern int daemon_type;
#define IS_DAEMON (daemon_type != 0)
+/* Non-zero means daemon-initialized has not yet been called. */
#define DAEMON_RUNNING (daemon_type >= 0)
#else /* WINDOWSNT */
extern void *w32_daemon_event;
@@ -5550,7 +5673,7 @@ safe_free_unbind_to (specpdl_ref count, specpdl_ref
sa_count, Lisp_Object val)
https://gcc.gnu.org/bugzilla/show_bug.cgi?id=109577
which causes GCC to mistakenly complain about the
memory allocation in SAFE_ALLOCA_LISP_EXTRA. */
-#if GNUC_PREREQ (13, 0, 0)
+#if GNUC_PREREQ (13, 0, 0) && !GNUC_PREREQ (14, 0, 0)
# pragma GCC diagnostic ignored "-Wanalyzer-allocation-size"
#endif
diff --git a/src/lread.c b/src/lread.c
index 929f86ef283..49683d02401 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2369,8 +2369,14 @@ build_load_history (Lisp_Object filename, bool entire)
front of load-history, the most-recently-loaded position. Also
do this if we didn't find an existing member for the file. */
if (entire || !foundit)
- Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
- Vload_history);
+ {
+ Lisp_Object tem = Fnreverse (Vcurrent_load_list);
+ eassert (EQ (filename, Fcar (tem)));
+ Vload_history = Fcons (tem, Vload_history);
+ /* FIXME: There should be an unbind_to right after calling us which
+ should re-establish the previous value of Vcurrent_load_list. */
+ Vcurrent_load_list = Qt;
+ }
}
static void
@@ -2437,11 +2443,13 @@ readevalloop (Lisp_Object readcharfun,
bool whole_buffer = 0;
/* True on the first time around. */
bool first_sexp = 1;
- Lisp_Object macroexpand = intern ("internal-macroexpand-for-load");
+ Lisp_Object macroexpand;
if (!NILP (sourcename))
CHECK_STRING (sourcename);
+ macroexpand = Qinternal_macroexpand_for_load;
+
if (NILP (Ffboundp (macroexpand))
|| (STRINGP (sourcename) && suffix_p (sourcename, ".elc")))
/* Don't macroexpand before the corresponding function is defined
@@ -3481,6 +3489,8 @@ vector_from_rev_list (Lisp_Object elems)
return obj;
}
+static Lisp_Object get_lazy_string (Lisp_Object val);
+
static Lisp_Object
bytecode_from_rev_list (Lisp_Object elems, Lisp_Object readcharfun)
{
@@ -3488,49 +3498,50 @@ bytecode_from_rev_list (Lisp_Object elems, Lisp_Object
readcharfun)
Lisp_Object *vec = XVECTOR (obj)->contents;
ptrdiff_t size = ASIZE (obj);
+ if (infile && size >= COMPILED_CONSTANTS)
+ {
+ /* Always read 'lazily-loaded' bytecode (generated by the
+ `byte-compile-dynamic' feature prior to Emacs 30) eagerly, to
+ avoid code in the fast path during execution. */
+ if (CONSP (vec[COMPILED_BYTECODE])
+ && FIXNUMP (XCDR (vec[COMPILED_BYTECODE])))
+ vec[COMPILED_BYTECODE] = get_lazy_string (vec[COMPILED_BYTECODE]);
+
+ /* Lazily-loaded bytecode is represented by the constant slot being nil
+ and the bytecode slot a (lazily loaded) string containing the
+ print representation of (BYTECODE . CONSTANTS). Unpack the
+ pieces by coerceing the string to unibyte and reading the result. */
+ if (NILP (vec[COMPILED_CONSTANTS]) && STRINGP (vec[COMPILED_BYTECODE]))
+ {
+ Lisp_Object enc = vec[COMPILED_BYTECODE];
+ Lisp_Object pair = Fread (Fcons (enc, readcharfun));
+ if (!CONSP (pair))
+ invalid_syntax ("Invalid byte-code object", readcharfun);
+
+ vec[COMPILED_BYTECODE] = XCAR (pair);
+ vec[COMPILED_CONSTANTS] = XCDR (pair);
+ }
+ }
+
if (!(size >= COMPILED_STACK_DEPTH + 1 && size <= COMPILED_INTERACTIVE + 1
&& (FIXNUMP (vec[COMPILED_ARGLIST])
|| CONSP (vec[COMPILED_ARGLIST])
|| NILP (vec[COMPILED_ARGLIST]))
+ && STRINGP (vec[COMPILED_BYTECODE])
+ && VECTORP (vec[COMPILED_CONSTANTS])
&& FIXNATP (vec[COMPILED_STACK_DEPTH])))
invalid_syntax ("Invalid byte-code object", readcharfun);
- if (load_force_doc_strings
- && NILP (vec[COMPILED_CONSTANTS])
- && STRINGP (vec[COMPILED_BYTECODE]))
- {
- /* Lazily-loaded bytecode is represented by the constant slot being nil
- and the bytecode slot a (lazily loaded) string containing the
- print representation of (BYTECODE . CONSTANTS). Unpack the
- pieces by coerceing the string to unibyte and reading the result. */
- Lisp_Object enc = vec[COMPILED_BYTECODE];
- Lisp_Object pair = Fread (Fcons (enc, readcharfun));
- if (!CONSP (pair))
- invalid_syntax ("Invalid byte-code object", readcharfun);
-
- vec[COMPILED_BYTECODE] = XCAR (pair);
- vec[COMPILED_CONSTANTS] = XCDR (pair);
- }
-
- if (!((STRINGP (vec[COMPILED_BYTECODE])
- && VECTORP (vec[COMPILED_CONSTANTS]))
- || CONSP (vec[COMPILED_BYTECODE])))
- invalid_syntax ("Invalid byte-code object", readcharfun);
+ if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE]))
+ /* BYTESTR must have been produced by Emacs 20.2 or earlier
+ because it produced a raw 8-bit string for byte-code and
+ now such a byte-code string is loaded as multibyte with
+ raw 8-bit characters converted to multibyte form.
+ Convert them back to the original unibyte form. */
+ vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]);
- if (STRINGP (vec[COMPILED_BYTECODE]))
- {
- if (STRING_MULTIBYTE (vec[COMPILED_BYTECODE]))
- {
- /* BYTESTR must have been produced by Emacs 20.2 or earlier
- because it produced a raw 8-bit string for byte-code and
- now such a byte-code string is loaded as multibyte with
- raw 8-bit characters converted to multibyte form.
- Convert them back to the original unibyte form. */
- vec[COMPILED_BYTECODE] = Fstring_as_unibyte (vec[COMPILED_BYTECODE]);
- }
- /* Bytecode must be immovable. */
- pin_string (vec[COMPILED_BYTECODE]);
- }
+ /* Bytecode must be immovable. */
+ pin_string (vec[COMPILED_BYTECODE]);
XSETPVECTYPE (XVECTOR (obj), PVEC_COMPILED);
return obj;
@@ -4469,7 +4480,7 @@ read0 (Lisp_Object readcharfun, bool locate_syms)
&longhand_chars,
&longhand_bytes);
- if (SYMBOLP (found))
+ if (BARE_SYMBOL_P (found))
result = found;
else if (longhand)
{
@@ -4875,49 +4886,65 @@ static Lisp_Object initial_obarray;
static size_t oblookup_last_bucket_number;
-/* Get an error if OBARRAY is not an obarray.
- If it is one, return it. */
+static Lisp_Object make_obarray (unsigned bits);
+/* Slow path obarray check: return the obarray to use or signal an error. */
Lisp_Object
-check_obarray (Lisp_Object obarray)
+check_obarray_slow (Lisp_Object obarray)
{
- /* We don't want to signal a wrong-type-argument error when we are
- shutting down due to a fatal error, and we don't want to hit
- assertions in VECTORP and ASIZE if the fatal error was during GC. */
- if (!fatal_error_in_progress
- && (!VECTORP (obarray) || ASIZE (obarray) == 0))
+ /* For compatibility, we accept vectors whose first element is 0,
+ and store an obarray object there. */
+ if (VECTORP (obarray) && ASIZE (obarray) > 0)
{
- /* If Vobarray is now invalid, force it to be valid. */
- if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;
- wrong_type_argument (Qvectorp, obarray);
+ Lisp_Object obj = AREF (obarray, 0);
+ if (OBARRAYP (obj))
+ return obj;
+ if (BASE_EQ (obj, make_fixnum (0)))
+ {
+ /* Put an actual obarray object in the first slot.
+ The rest of the vector remains unused. */
+ obj = make_obarray (0);
+ ASET (obarray, 0, obj);
+ return obj;
+ }
}
- return obarray;
+ /* Reset Vobarray to the standard obarray for nicer error handling. */
+ if (BASE_EQ (Vobarray, obarray)) Vobarray = initial_obarray;
+
+ wrong_type_argument (Qobarrayp, obarray);
}
+static void grow_obarray (struct Lisp_Obarray *o);
+
/* Intern symbol SYM in OBARRAY using bucket INDEX. */
+/* FIXME: retype arguments as pure C types */
static Lisp_Object
intern_sym (Lisp_Object sym, Lisp_Object obarray, Lisp_Object index)
{
- Lisp_Object *ptr;
+ eassert (BARE_SYMBOL_P (sym) && OBARRAYP (obarray) && FIXNUMP (index));
+ struct Lisp_Symbol *s = XBARE_SYMBOL (sym);
+ s->u.s.interned = (BASE_EQ (obarray, initial_obarray)
+ ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY
+ : SYMBOL_INTERNED);
- XSYMBOL (sym)->u.s.interned = (EQ (obarray, initial_obarray)
- ? SYMBOL_INTERNED_IN_INITIAL_OBARRAY
- : SYMBOL_INTERNED);
-
- if (SREF (SYMBOL_NAME (sym), 0) == ':' && EQ (obarray, initial_obarray))
+ if (SREF (s->u.s.name, 0) == ':' && BASE_EQ (obarray, initial_obarray))
{
- make_symbol_constant (sym);
- XSYMBOL (sym)->u.s.redirect = SYMBOL_PLAINVAL;
+ s->u.s.trapped_write = SYMBOL_NOWRITE;
+ s->u.s.redirect = SYMBOL_PLAINVAL;
/* Mark keywords as special. This makes (let ((:key 'foo)) ...)
in lexically bound elisp signal an error, as documented. */
- XSYMBOL (sym)->u.s.declared_special = true;
- SET_SYMBOL_VAL (XSYMBOL (sym), sym);
+ s->u.s.declared_special = true;
+ SET_SYMBOL_VAL (s, sym);
}
- ptr = aref_addr (obarray, XFIXNUM (index));
- set_symbol_next (sym, SYMBOLP (*ptr) ? XSYMBOL (*ptr) : NULL);
+ struct Lisp_Obarray *o = XOBARRAY (obarray);
+ Lisp_Object *ptr = o->buckets + XFIXNUM (index);
+ s->u.s.next = BARE_SYMBOL_P (*ptr) ? XBARE_SYMBOL (*ptr) : NULL;
*ptr = sym;
+ o->count++;
+ if (o->count > obarray_size (o))
+ grow_obarray (o);
return sym;
}
@@ -4926,7 +4953,7 @@ intern_sym (Lisp_Object sym, Lisp_Object obarray,
Lisp_Object index)
Lisp_Object
intern_driver (Lisp_Object string, Lisp_Object obarray, Lisp_Object index)
{
- SET_SYMBOL_VAL (XSYMBOL (Qobarray_cache), Qnil);
+ SET_SYMBOL_VAL (XBARE_SYMBOL (Qobarray_cache), Qnil);
return intern_sym (Fmake_symbol (string), obarray, index);
}
@@ -4939,7 +4966,7 @@ intern_1 (const char *str, ptrdiff_t len)
Lisp_Object obarray = check_obarray (Vobarray);
Lisp_Object tem = oblookup (obarray, str, len, len);
- return (SYMBOLP (tem) ? tem
+ return (BARE_SYMBOL_P (tem) ? tem
/* The above `oblookup' was done on the basis of nchars==nbytes, so
the string has to be unibyte. */
: intern_driver (make_unibyte_string (str, len),
@@ -4952,7 +4979,7 @@ intern_c_string_1 (const char *str, ptrdiff_t len)
Lisp_Object obarray = check_obarray (Vobarray);
Lisp_Object tem = oblookup (obarray, str, len, len);
- if (!SYMBOLP (tem))
+ if (!BARE_SYMBOL_P (tem))
{
Lisp_Object string;
@@ -5004,7 +5031,7 @@ it defaults to the value of `obarray'. */)
&longhand, &longhand_chars,
&longhand_bytes);
- if (!SYMBOLP (tem))
+ if (!BARE_SYMBOL_P (tem))
{
if (longhand)
{
@@ -5053,10 +5080,11 @@ it defaults to the value of `obarray'. */)
{
/* If already a symbol, we don't do shorthand-longhand translation,
as promised in the docstring. */
- string = SYMBOL_NAME (name);
+ Lisp_Object sym = maybe_remove_pos_from_symbol (name);
+ string = XSYMBOL (name)->u.s.name;
tem
= oblookup (obarray, SSDATA (string), SCHARS (string), SBYTES (string));
- return EQ (name, tem) ? name : Qnil;
+ return BASE_EQ (sym, tem) ? name : Qnil;
}
}
@@ -5071,13 +5099,16 @@ usage: (unintern NAME OBARRAY) */)
{
register Lisp_Object tem;
Lisp_Object string;
- size_t hash;
if (NILP (obarray)) obarray = Vobarray;
obarray = check_obarray (obarray);
if (SYMBOLP (name))
- string = SYMBOL_NAME (name);
+ {
+ if (!BARE_SYMBOL_P (name))
+ name = XSYMBOL_WITH_POS (name)->sym;
+ string = SYMBOL_NAME (name);
+ }
else
{
CHECK_STRING (name);
@@ -5097,7 +5128,7 @@ usage: (unintern NAME OBARRAY) */)
if (FIXNUMP (tem))
return Qnil;
/* If arg was a symbol, don't delete anything but that symbol itself. */
- if (SYMBOLP (name) && !EQ (name, tem))
+ if (BARE_SYMBOL_P (name) && !BASE_EQ (name, tem))
return Qnil;
/* There are plenty of other symbols which will screw up the Emacs
@@ -5107,41 +5138,42 @@ usage: (unintern NAME OBARRAY) */)
/* if (NILP (tem) || EQ (tem, Qt))
error ("Attempt to unintern t or nil"); */
- XSYMBOL (tem)->u.s.interned = SYMBOL_UNINTERNED;
+ struct Lisp_Symbol *sym = XBARE_SYMBOL (tem);
+ sym->u.s.interned = SYMBOL_UNINTERNED;
- hash = oblookup_last_bucket_number;
+ ptrdiff_t idx = oblookup_last_bucket_number;
+ Lisp_Object *loc = &XOBARRAY (obarray)->buckets[idx];
- if (EQ (AREF (obarray, hash), tem))
- {
- if (XSYMBOL (tem)->u.s.next)
- {
- Lisp_Object sym;
- XSETSYMBOL (sym, XSYMBOL (tem)->u.s.next);
- ASET (obarray, hash, sym);
- }
- else
- ASET (obarray, hash, make_fixnum (0));
- }
+ eassert (BARE_SYMBOL_P (*loc));
+ struct Lisp_Symbol *prev = XBARE_SYMBOL (*loc);
+ if (sym == prev)
+ *loc = sym->u.s.next ? make_lisp_symbol (sym->u.s.next) : make_fixnum (0);
else
- {
- Lisp_Object tail, following;
+ while (1)
+ {
+ struct Lisp_Symbol *next = prev->u.s.next;
+ if (next == sym)
+ {
+ prev->u.s.next = next->u.s.next;
+ break;
+ }
+ prev = next;
+ }
- for (tail = AREF (obarray, hash);
- XSYMBOL (tail)->u.s.next;
- tail = following)
- {
- XSETSYMBOL (following, XSYMBOL (tail)->u.s.next);
- if (EQ (following, tem))
- {
- set_symbol_next (tail, XSYMBOL (following)->u.s.next);
- break;
- }
- }
- }
+ XOBARRAY (obarray)->count--;
return Qt;
}
+
+/* Bucket index of the string STR of length SIZE_BYTE bytes in obarray OA. */
+static ptrdiff_t
+obarray_index (struct Lisp_Obarray *oa, const char *str, ptrdiff_t size_byte)
+{
+ EMACS_UINT hash = hash_string (str, size_byte);
+ return knuth_hash (reduce_emacs_uint_to_hash_hash (hash), oa->size_bits);
+}
+
/* Return the symbol in OBARRAY whose names matches the string
of SIZE characters (SIZE_BYTE bytes) at PTR.
If there is no such symbol, return the integer bucket number of
@@ -5152,35 +5184,27 @@ usage: (unintern NAME OBARRAY) */)
Lisp_Object
oblookup (Lisp_Object obarray, register const char *ptr, ptrdiff_t size,
ptrdiff_t size_byte)
{
- size_t hash;
- size_t obsize;
- register Lisp_Object tail;
- Lisp_Object bucket, tem;
+ struct Lisp_Obarray *o = XOBARRAY (obarray);
+ ptrdiff_t idx = obarray_index (o, ptr, size_byte);
+ Lisp_Object bucket = o->buckets[idx];
- obarray = check_obarray (obarray);
- /* This is sometimes needed in the middle of GC. */
- obsize = gc_asize (obarray);
- hash = hash_string (ptr, size_byte) % obsize;
- bucket = AREF (obarray, hash);
- oblookup_last_bucket_number = hash;
- if (BASE_EQ (bucket, make_fixnum (0)))
- ;
- else if (!SYMBOLP (bucket))
- /* Like CADR error message. */
- xsignal2 (Qwrong_type_argument, Qobarrayp,
- build_string ("Bad data in guts of obarray"));
- else
- for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next))
- {
- if (SBYTES (SYMBOL_NAME (tail)) == size_byte
- && SCHARS (SYMBOL_NAME (tail)) == size
- && !memcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
- return tail;
- else if (XSYMBOL (tail)->u.s.next == 0)
- break;
- }
- XSETINT (tem, hash);
- return tem;
+ oblookup_last_bucket_number = idx;
+ if (!BASE_EQ (bucket, make_fixnum (0)))
+ {
+ Lisp_Object sym = bucket;
+ while (1)
+ {
+ struct Lisp_Symbol *s = XBARE_SYMBOL (sym);
+ Lisp_Object name = s->u.s.name;
+ if (SBYTES (name) == size_byte && SCHARS (name) == size
+ && memcmp (SDATA (name), ptr, size_byte) == 0)
+ return sym;
+ if (s->u.s.next == NULL)
+ break;
+ sym = make_lisp_symbol(s->u.s.next);
+ }
+ }
+ return make_fixnum (idx);
}
/* Like 'oblookup', but considers 'Vread_symbol_shorthands',
@@ -5247,24 +5271,134 @@ oblookup_considering_shorthand (Lisp_Object obarray,
const char *in,
}
-void
-map_obarray (Lisp_Object obarray, void (*fn) (Lisp_Object, Lisp_Object),
Lisp_Object arg)
+static struct Lisp_Obarray *
+allocate_obarray (void)
+{
+ return ALLOCATE_PLAIN_PSEUDOVECTOR (struct Lisp_Obarray, PVEC_OBARRAY);
+}
+
+static Lisp_Object
+make_obarray (unsigned bits)
+{
+ struct Lisp_Obarray *o = allocate_obarray ();
+ o->count = 0;
+ o->size_bits = bits;
+ ptrdiff_t size = (ptrdiff_t)1 << bits;
+ o->buckets = hash_table_alloc_bytes (size * sizeof *o->buckets);
+ for (ptrdiff_t i = 0; i < size; i++)
+ o->buckets[i] = make_fixnum (0);
+ return make_lisp_obarray (o);
+}
+
+enum {
+ obarray_default_bits = 3,
+ word_size_log2 = word_size < 8 ? 5 : 6, /* good enough */
+ obarray_max_bits = min (8 * sizeof (int),
+ 8 * sizeof (ptrdiff_t) - word_size_log2) - 1,
+};
+
+static void
+grow_obarray (struct Lisp_Obarray *o)
{
- ptrdiff_t i;
- register Lisp_Object tail;
- CHECK_VECTOR (obarray);
- for (i = ASIZE (obarray) - 1; i >= 0; i--)
+ ptrdiff_t old_size = obarray_size (o);
+ eassert (o->count > old_size);
+ Lisp_Object *old_buckets = o->buckets;
+
+ int new_bits = o->size_bits + 1;
+ if (new_bits > obarray_max_bits)
+ error ("Obarray too big");
+ ptrdiff_t new_size = (ptrdiff_t)1 << new_bits;
+ o->buckets = hash_table_alloc_bytes (new_size * sizeof *o->buckets);
+ for (ptrdiff_t i = 0; i < new_size; i++)
+ o->buckets[i] = make_fixnum (0);
+ o->size_bits = new_bits;
+
+ /* Rehash symbols.
+ FIXME: this is expensive since we need to recompute the hash for every
+ symbol name. Would it be reasonable to store it in the symbol? */
+ for (ptrdiff_t i = 0; i < old_size; i++)
{
- tail = AREF (obarray, i);
- if (SYMBOLP (tail))
- while (1)
- {
- (*fn) (tail, arg);
- if (XSYMBOL (tail)->u.s.next == 0)
- break;
- XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next);
- }
+ Lisp_Object obj = old_buckets[i];
+ if (BARE_SYMBOL_P (obj))
+ {
+ struct Lisp_Symbol *s = XBARE_SYMBOL (obj);
+ while (1)
+ {
+ Lisp_Object name = s->u.s.name;
+ ptrdiff_t idx = obarray_index (o, SSDATA (name), SBYTES (name));
+ Lisp_Object *loc = o->buckets + idx;
+ struct Lisp_Symbol *next = s->u.s.next;
+ s->u.s.next = BARE_SYMBOL_P (*loc) ? XBARE_SYMBOL (*loc) : NULL;
+ *loc = make_lisp_symbol (s);
+ if (next == NULL)
+ break;
+ s = next;
+ }
+ }
+ }
+
+ hash_table_free_bytes (old_buckets, old_size * sizeof *old_buckets);
+}
+
+DEFUN ("obarray-make", Fobarray_make, Sobarray_make, 0, 1, 0,
+ doc: /* Return a new obarray of size SIZE.
+The obarray will grow to accommodate any number of symbols; the size, if
+given, is only a hint for the expected number. */)
+ (Lisp_Object size)
+{
+ int bits;
+ if (NILP (size))
+ bits = obarray_default_bits;
+ else
+ {
+ CHECK_FIXNAT (size);
+ EMACS_UINT n = XFIXNUM (size);
+ bits = elogb (n) + 1;
+ if (bits > obarray_max_bits)
+ xsignal (Qargs_out_of_range, size);
}
+ return make_obarray (bits);
+}
+
+DEFUN ("obarrayp", Fobarrayp, Sobarrayp, 1, 1, 0,
+ doc: /* Return t iff OBJECT is an obarray. */)
+ (Lisp_Object object)
+{
+ return OBARRAYP (object) ? Qt : Qnil;
+}
+
+DEFUN ("obarray-clear", Fobarray_clear, Sobarray_clear, 1, 1, 0,
+ doc: /* Remove all symbols from OBARRAY. */)
+ (Lisp_Object obarray)
+{
+ CHECK_OBARRAY (obarray);
+ struct Lisp_Obarray *o = XOBARRAY (obarray);
+
+ /* This function does not bother setting the status of its contained symbols
+ to uninterned. It doesn't matter very much. */
+ int new_bits = obarray_default_bits;
+ int new_size = (ptrdiff_t)1 << new_bits;
+ Lisp_Object *new_buckets
+ = hash_table_alloc_bytes (new_size * sizeof *new_buckets);
+ for (ptrdiff_t i = 0; i < new_size; i++)
+ new_buckets[i] = make_fixnum (0);
+
+ int old_size = obarray_size (o);
+ hash_table_free_bytes (o->buckets, old_size * sizeof *o->buckets);
+ o->buckets = new_buckets;
+ o->size_bits = new_bits;
+ o->count = 0;
+
+ return Qnil;
+}
+
+void
+map_obarray (Lisp_Object obarray,
+ void (*fn) (Lisp_Object, Lisp_Object), Lisp_Object arg)
+{
+ CHECK_OBARRAY (obarray);
+ DOOBARRAY (XOBARRAY (obarray), it)
+ (*fn) (obarray_iter_symbol (&it), arg);
}
static void
@@ -5285,12 +5419,37 @@ OBARRAY defaults to the value of `obarray'. */)
return Qnil;
}
-#define OBARRAY_SIZE 15121
+DEFUN ("internal--obarray-buckets",
+ Finternal__obarray_buckets, Sinternal__obarray_buckets, 1, 1, 0,
+ doc: /* Symbols in each bucket of OBARRAY. Internal use only. */)
+ (Lisp_Object obarray)
+{
+ obarray = check_obarray (obarray);
+ ptrdiff_t size = obarray_size (XOBARRAY (obarray));
+
+ Lisp_Object ret = Qnil;
+ for (ptrdiff_t i = 0; i < size; i++)
+ {
+ Lisp_Object bucket = Qnil;
+ Lisp_Object sym = XOBARRAY (obarray)->buckets[i];
+ if (BARE_SYMBOL_P (sym))
+ while (1)
+ {
+ bucket = Fcons (sym, bucket);
+ struct Lisp_Symbol *s = XBARE_SYMBOL (sym)->u.s.next;
+ if (!s)
+ break;
+ sym = make_lisp_symbol (s);
+ }
+ ret = Fcons (Fnreverse (bucket), ret);
+ }
+ return Fnreverse (ret);
+}
void
init_obarray_once (void)
{
- Vobarray = make_vector (OBARRAY_SIZE, make_fixnum (0));
+ Vobarray = make_obarray (15);
initial_obarray = Vobarray;
staticpro (&initial_obarray);
@@ -5300,14 +5459,14 @@ init_obarray_once (void)
DEFSYM (Qunbound, "unbound");
DEFSYM (Qnil, "nil");
- SET_SYMBOL_VAL (XSYMBOL (Qnil), Qnil);
+ SET_SYMBOL_VAL (XBARE_SYMBOL (Qnil), Qnil);
make_symbol_constant (Qnil);
- XSYMBOL (Qnil)->u.s.declared_special = true;
+ XBARE_SYMBOL (Qnil)->u.s.declared_special = true;
DEFSYM (Qt, "t");
- SET_SYMBOL_VAL (XSYMBOL (Qt), Qt);
+ SET_SYMBOL_VAL (XBARE_SYMBOL (Qt), Qt);
make_symbol_constant (Qt);
- XSYMBOL (Qt)->u.s.declared_special = true;
+ XBARE_SYMBOL (Qt)->u.s.declared_special = true;
/* Qt is correct even if not dumping. loadup.el will set to nil at end. */
Vpurify_flag = Qt;
@@ -5331,16 +5490,6 @@ defsubr (union Aligned_Lisp_Subr *aname)
#endif
}
-#ifdef NOTDEF /* Use fset in subr.el now! */
-void
-defalias (struct Lisp_Subr *sname, char *string)
-{
- Lisp_Object sym;
- sym = intern (string);
- XSETSUBR (XSYMBOL (sym)->u.s.function, sname);
-}
-#endif /* NOTDEF */
-
/* Define an "integer variable"; a symbol whose value is forwarded to a
C variable of type intmax_t. Sample call (with "xx" to fool make-docfile):
DEFxxVAR_INT ("emacs-priority", &emacs_priority, "Documentation"); */
@@ -5348,9 +5497,9 @@ void
defvar_int (struct Lisp_Intfwd const *i_fwd, char const *namestring)
{
Lisp_Object sym = intern_c_string (namestring);
- XSYMBOL (sym)->u.s.declared_special = true;
- XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), i_fwd);
+ XBARE_SYMBOL (sym)->u.s.declared_special = true;
+ XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_FWD (XBARE_SYMBOL (sym), i_fwd);
}
/* Similar but define a variable whose value is t if 1, nil if 0. */
@@ -5358,9 +5507,9 @@ void
defvar_bool (struct Lisp_Boolfwd const *b_fwd, char const *namestring)
{
Lisp_Object sym = intern_c_string (namestring);
- XSYMBOL (sym)->u.s.declared_special = true;
- XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), b_fwd);
+ XBARE_SYMBOL (sym)->u.s.declared_special = true;
+ XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_FWD (XBARE_SYMBOL (sym), b_fwd);
Vbyte_boolean_vars = Fcons (sym, Vbyte_boolean_vars);
}
@@ -5373,9 +5522,9 @@ void
defvar_lisp_nopro (struct Lisp_Objfwd const *o_fwd, char const *namestring)
{
Lisp_Object sym = intern_c_string (namestring);
- XSYMBOL (sym)->u.s.declared_special = true;
- XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), o_fwd);
+ XBARE_SYMBOL (sym)->u.s.declared_special = true;
+ XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_FWD (XBARE_SYMBOL (sym), o_fwd);
}
void
@@ -5392,9 +5541,9 @@ void
defvar_kboard (struct Lisp_Kboard_Objfwd const *ko_fwd, char const *namestring)
{
Lisp_Object sym = intern_c_string (namestring);
- XSYMBOL (sym)->u.s.declared_special = true;
- XSYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
- SET_SYMBOL_FWD (XSYMBOL (sym), ko_fwd);
+ XBARE_SYMBOL (sym)->u.s.declared_special = true;
+ XBARE_SYMBOL (sym)->u.s.redirect = SYMBOL_FORWARDED;
+ SET_SYMBOL_FWD (XBARE_SYMBOL (sym), ko_fwd);
}
/* Check that the elements of lpath exist. */
@@ -5682,6 +5831,10 @@ syms_of_lread (void)
defsubr (&Sget_file_char);
defsubr (&Smapatoms);
defsubr (&Slocate_file_internal);
+ defsubr (&Sinternal__obarray_buckets);
+ defsubr (&Sobarray_make);
+ defsubr (&Sobarrayp);
+ defsubr (&Sobarray_clear);
DEFVAR_LISP ("obarray", Vobarray,
doc: /* Symbol table for use by `intern' and `read'.
@@ -5693,7 +5846,7 @@ to find all the symbols in an obarray, use `mapatoms'.
*/);
doc: /* List of values of all expressions which were read,
evaluated and printed.
Order is reverse chronological.
This variable is obsolete as of Emacs 28.1 and should not be used. */);
- XSYMBOL (intern ("values"))->u.s.declared_special = false;
+ XBARE_SYMBOL (intern ("values"))->u.s.declared_special = false;
DEFVAR_LISP ("standard-input", Vstandard_input,
doc: /* Stream for read to get input from.
@@ -6007,4 +6160,7 @@ See Info node `(elisp)Shorthands' for more details. */);
doc: /* List of variables declared dynamic in the current scope.
Only valid during macro-expansion. Internal use only. */);
Vmacroexp__dynvars = Qnil;
+
+ DEFSYM (Qinternal_macroexpand_for_load,
+ "internal-macroexpand-for-load");
}
diff --git a/src/macfont.m b/src/macfont.m
index 6f192b00f1b..e3b3d40df43 100644
--- a/src/macfont.m
+++ b/src/macfont.m
@@ -855,21 +855,42 @@ macfont_store_descriptor_attributes (CTFontDescriptorRef
desc,
struct {
enum font_property_index index;
CFStringRef trait;
- CGPoint points[6];
- CGFloat (*adjust_func) (CTFontDescriptorRef, CGFloat);
- } numeric_traits[] =
- {{FONT_WEIGHT_INDEX, kCTFontWeightTrait,
- {{-0.4, 50}, /* light */
- {-0.24, 87.5}, /* (semi-light + normal) / 2 */
- {0, 80}, /* normal */
- {0.24, 140}, /* (semi-bold + normal) / 2 */
- {0.4, 200}, /* bold */
- {CGFLOAT_MAX, CGFLOAT_MAX}},
- mac_font_descriptor_get_adjusted_weight},
- {FONT_SLANT_INDEX, kCTFontSlantTrait,
- {{0, 100}, {0.1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}, NULL},
- {FONT_WIDTH_INDEX, kCTFontWidthTrait,
- {{0, 100}, {1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}, NULL}};
+ CGPoint points[12];
+ CGFloat (*adjust_func) (CTFontDescriptorRef, CGFloat);
+ } numeric_traits[] = {
+ { FONT_WEIGHT_INDEX,
+ kCTFontWeightTrait,
+ { { -0.6, 0 }, /* thin */
+ { -0.4, 40 }, /* ultra-light, ultralight, extra-light,
extralight */
+ { -0.23, 50 }, /* light */
+ { -0.115, 55 }, /* semi-light, semilight, demilight */
+ { 0, 80 }, /* regular, normal, unspecified, book */
+ { 0.2, 100 }, /* medium */
+ { 0.3, 180 }, /* semi-bold, semibold, demibold, demi-bold, demi
*/
+ { 0.4, 200 }, /* bold */
+ { 0.6, 205 }, /* extra-bold, extrabold, ultra-bold, ultrabold */
+ { 0.8, 210 }, /* black, heavy */
+ { 1, 250 }, /* ultra-heavy, ultraheavy */
+ { CGFLOAT_MAX, CGFLOAT_MAX } },
+ mac_font_descriptor_get_adjusted_weight },
+ { FONT_SLANT_INDEX,
+ kCTFontSlantTrait,
+ { { 0, 100 }, { 0.1, 200 }, { CGFLOAT_MAX, CGFLOAT_MAX } },
+ NULL },
+ { FONT_WIDTH_INDEX,
+ kCTFontWidthTrait,
+ { { -0.4, 50 }, /* ultra-condensed, ultracondensed */
+ { -0.3, 63 }, /* extra-condensed, extracondensed */
+ { -0.2, 75 }, /* condensed, compressed, narrow */
+ { -0.1, 87 }, /* semi-condensed, semicondensed, demicondensed */
+ { 0, 100 }, /* normal, medium, regular, unspecified */
+ { 0.1, 113 }, /* semi-expanded, semiexpanded, demiexpanded */
+ { 0.2, 125 }, /* expanded */
+ { 0.3, 150 }, /* extra-expanded, extraexpanded */
+ { 0.4, 200 }, /* ultra-expanded, ultraexpanded, wide */
+ { CGFLOAT_MAX, CGFLOAT_MAX } },
+ NULL }
+ };
int i;
for (i = 0; i < ARRAYELTS (numeric_traits); i++)
@@ -1941,19 +1962,38 @@ macfont_create_attributes_with_spec (Lisp_Object spec)
struct {
enum font_property_index index;
CFStringRef trait;
- CGPoint points[6];
- } numeric_traits[] =
- {{FONT_WEIGHT_INDEX, kCTFontWeightTrait,
- {{-0.4, 50}, /* light */
- {-0.24, 87.5}, /* (semi-light + normal) / 2 */
- {0, 100}, /* normal */
- {0.24, 140}, /* (semi-bold + normal) / 2 */
- {0.4, 200}, /* bold */
- {CGFLOAT_MAX, CGFLOAT_MAX}}},
- {FONT_SLANT_INDEX, kCTFontSlantTrait,
- {{0, 100}, {0.1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}},
- {FONT_WIDTH_INDEX, kCTFontWidthTrait,
- {{0, 100}, {1, 200}, {CGFLOAT_MAX, CGFLOAT_MAX}}}};
+ CGPoint points[12];
+ } numeric_traits[] = {
+ { FONT_WEIGHT_INDEX,
+ kCTFontWeightTrait,
+ { { -0.6, 0 }, /* thin */
+ { -0.4, 40 }, /* ultra-light, ultralight, extra-light, extralight */
+ { -0.23, 50 }, /* light */
+ { -0.115, 55 }, /* semi-light, semilight, demilight */
+ { 0, 80 }, /* regular, normal, unspecified, book */
+ { 0.2, 100 }, /* medium */
+ { 0.3, 180 }, /* semi-bold, semibold, demibold, demi-bold, demi */
+ { 0.4, 200 }, /* bold */
+ { 0.6, 205 }, /* extra-bold, extrabold, ultra-bold, ultrabold */
+ { 0.8, 210 }, /* black, heavy */
+ { 1, 250 }, /* ultra-heavy, ultraheavy */
+ { CGFLOAT_MAX, CGFLOAT_MAX } } },
+ { FONT_SLANT_INDEX,
+ kCTFontSlantTrait,
+ { { 0, 100 }, { 0.1, 200 }, { CGFLOAT_MAX, CGFLOAT_MAX } } },
+ { FONT_WIDTH_INDEX,
+ kCTFontWidthTrait,
+ { { -0.4, 50 }, /* ultra-condensed, ultracondensed */
+ { -0.3, 63 }, /* extra-condensed, extracondensed */
+ { -0.2, 75 }, /* condensed, compressed, narrow */
+ { -0.1, 87 }, /* semi-condensed, semicondensed, demicondensed */
+ { 0, 100 }, /* normal, medium, regular, unspecified */
+ { 0.1, 113 }, /* semi-expanded, semiexpanded, demiexpanded */
+ { 0.2, 125 }, /* expanded */
+ { 0.3, 150 }, /* extra-expanded, extraexpanded */
+ { 0.4, 200 }, /* ultra-expanded, ultraexpanded, wide */
+ { CGFLOAT_MAX, CGFLOAT_MAX } } }
+ };
registry = AREF (spec, FONT_REGISTRY_INDEX);
if (NILP (registry)
diff --git a/src/marker.c b/src/marker.c
index 0101e144b4d..1559dd52719 100644
--- a/src/marker.c
+++ b/src/marker.c
@@ -21,7 +21,7 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <config.h>
/* Work around GCC bug 113253. */
-#if 13 <= __GNUC__
+#if __GNUC__ == 13
# pragma GCC diagnostic ignored "-Wanalyzer-deref-before-check"
#endif
diff --git a/src/minibuf.c b/src/minibuf.c
index 7c0c9799a60..df6ca7ce1d8 100644
--- a/src/minibuf.c
+++ b/src/minibuf.c
@@ -1615,13 +1615,15 @@ or from one of the possible completions. */)
ptrdiff_t bestmatchsize = 0;
/* These are in bytes, too. */
ptrdiff_t compare, matchsize;
+ if (VECTORP (collection))
+ collection = check_obarray (collection);
enum { function_table, list_table, obarray_table, hash_table}
type = (HASH_TABLE_P (collection) ? hash_table
- : VECTORP (collection) ? obarray_table
+ : OBARRAYP (collection) ? obarray_table
: ((NILP (collection)
|| (CONSP (collection) && !FUNCTIONP (collection)))
? list_table : function_table));
- ptrdiff_t idx = 0, obsize = 0;
+ ptrdiff_t idx = 0;
int matchcount = 0;
Lisp_Object bucket, zero, end, tem;
@@ -1634,12 +1636,9 @@ or from one of the possible completions. */)
/* If COLLECTION is not a list, set TAIL just for gc pro. */
tail = collection;
+ obarray_iter_t obit;
if (type == obarray_table)
- {
- collection = check_obarray (collection);
- obsize = ASIZE (collection);
- bucket = AREF (collection, idx);
- }
+ obit = make_obarray_iter (XOBARRAY (collection));
while (1)
{
@@ -1658,24 +1657,10 @@ or from one of the possible completions. */)
}
else if (type == obarray_table)
{
- if (!EQ (bucket, zero))
- {
- if (!SYMBOLP (bucket))
- error ("Bad data in guts of obarray");
- elt = bucket;
- eltstring = elt;
- if (XSYMBOL (bucket)->u.s.next)
- XSETSYMBOL (bucket, XSYMBOL (bucket)->u.s.next);
- else
- XSETFASTINT (bucket, 0);
- }
- else if (++idx >= obsize)
+ if (obarray_iter_at_end (&obit))
break;
- else
- {
- bucket = AREF (collection, idx);
- continue;
- }
+ elt = eltstring = obarray_iter_symbol (&obit);
+ obarray_iter_step (&obit);
}
else /* if (type == hash_table) */
{
@@ -1858,10 +1843,12 @@ with a space are ignored unless STRING itself starts
with a space. */)
{
Lisp_Object tail, elt, eltstring;
Lisp_Object allmatches;
+ if (VECTORP (collection))
+ collection = check_obarray (collection);
int type = HASH_TABLE_P (collection) ? 3
- : VECTORP (collection) ? 2
+ : OBARRAYP (collection) ? 2
: NILP (collection) || (CONSP (collection) && !FUNCTIONP (collection));
- ptrdiff_t idx = 0, obsize = 0;
+ ptrdiff_t idx = 0;
Lisp_Object bucket, tem, zero;
CHECK_STRING (string);
@@ -1872,12 +1859,9 @@ with a space are ignored unless STRING itself starts
with a space. */)
/* If COLLECTION is not a list, set TAIL just for gc pro. */
tail = collection;
+ obarray_iter_t obit;
if (type == 2)
- {
- collection = check_obarray (collection);
- obsize = ASIZE (collection);
- bucket = AREF (collection, idx);
- }
+ obit = make_obarray_iter (XOBARRAY (collection));
while (1)
{
@@ -1896,24 +1880,10 @@ with a space are ignored unless STRING itself starts
with a space. */)
}
else if (type == 2)
{
- if (!EQ (bucket, zero))
- {
- if (!SYMBOLP (bucket))
- error ("Bad data in guts of obarray");
- elt = bucket;
- eltstring = elt;
- if (XSYMBOL (bucket)->u.s.next)
- XSETSYMBOL (bucket, XSYMBOL (bucket)->u.s.next);
- else
- XSETFASTINT (bucket, 0);
- }
- else if (++idx >= obsize)
+ if (obarray_iter_at_end (&obit))
break;
- else
- {
- bucket = AREF (collection, idx);
- continue;
- }
+ elt = eltstring = obarray_iter_symbol (&obit);
+ obarray_iter_step (&obit);
}
else /* if (type == 3) */
{
@@ -2059,7 +2029,7 @@ If COLLECTION is a function, it is called with three
arguments:
the values STRING, PREDICATE and `lambda'. */)
(Lisp_Object string, Lisp_Object collection, Lisp_Object predicate)
{
- Lisp_Object tail, tem = Qnil, arg = Qnil;
+ Lisp_Object tem = Qnil, arg = Qnil;
CHECK_STRING (string);
@@ -2069,38 +2039,30 @@ the values STRING, PREDICATE and `lambda'. */)
if (NILP (tem))
return Qnil;
}
- else if (VECTORP (collection))
+ else if (OBARRAYP (collection) || VECTORP (collection))
{
+ collection = check_obarray (collection);
/* Bypass intern-soft as that loses for nil. */
tem = oblookup (collection,
SSDATA (string),
SCHARS (string),
SBYTES (string));
- if (completion_ignore_case && !SYMBOLP (tem))
- {
- for (ptrdiff_t i = ASIZE (collection) - 1; i >= 0; i--)
- {
- tail = AREF (collection, i);
- if (SYMBOLP (tail))
- while (1)
- {
- if (BASE_EQ (Fcompare_strings (string, make_fixnum (0),
- Qnil,
- Fsymbol_name (tail),
- make_fixnum (0) , Qnil, Qt),
- Qt))
- {
- tem = tail;
- break;
- }
- if (XSYMBOL (tail)->u.s.next == 0)
- break;
- XSETSYMBOL (tail, XSYMBOL (tail)->u.s.next);
- }
- }
- }
+ if (completion_ignore_case && !BARE_SYMBOL_P (tem))
+ DOOBARRAY (XOBARRAY (collection), it)
+ {
+ Lisp_Object obj = obarray_iter_symbol (&it);
+ if (BASE_EQ (Fcompare_strings (string, make_fixnum (0),
+ Qnil,
+ Fsymbol_name (obj),
+ make_fixnum (0) , Qnil, Qt),
+ Qt))
+ {
+ tem = obj;
+ break;
+ }
+ }
- if (!SYMBOLP (tem))
+ if (!BARE_SYMBOL_P (tem))
return Qnil;
}
else if (HASH_TABLE_P (collection))
diff --git a/src/pdumper.c b/src/pdumper.c
index ee554cda55a..f0bce09cbde 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -2688,7 +2688,7 @@ hash_table_freeze (struct Lisp_Hash_Table *h)
h->hash = NULL;
h->index = NULL;
h->table_size = 0;
- h->index_size = 0;
+ h->index_bits = 0;
h->frozen_test = hash_table_std_test (h->test);
h->test = NULL;
}
@@ -2719,7 +2719,7 @@ dump_hash_table_contents (struct dump_context *ctx,
struct Lisp_Hash_Table *h)
static dump_off
dump_hash_table (struct dump_context *ctx, Lisp_Object object)
{
-#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_313A489F0A
+#if CHECK_STRUCTS && !defined HASH_Lisp_Hash_Table_0360833954
# error "Lisp_Hash_Table changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Hash_Table *hash_in = XHASH_TABLE (object);
@@ -2748,6 +2748,51 @@ dump_hash_table (struct dump_context *ctx, Lisp_Object
object)
return offset;
}
+static dump_off
+dump_obarray_buckets (struct dump_context *ctx, const struct Lisp_Obarray *o)
+{
+ dump_align_output (ctx, DUMP_ALIGNMENT);
+ dump_off start_offset = ctx->offset;
+ ptrdiff_t n = obarray_size (o);
+
+ struct dump_flags old_flags = ctx->flags;
+ ctx->flags.pack_objects = true;
+
+ for (ptrdiff_t i = 0; i < n; i++)
+ {
+ Lisp_Object out;
+ const Lisp_Object *slot = &o->buckets[i];
+ dump_object_start (ctx, &out, sizeof out);
+ dump_field_lv (ctx, &out, slot, slot, WEIGHT_STRONG);
+ dump_object_finish (ctx, &out, sizeof out);
+ }
+
+ ctx->flags = old_flags;
+ return start_offset;
+}
+
+static dump_off
+dump_obarray (struct dump_context *ctx, Lisp_Object object)
+{
+#if CHECK_STRUCTS && !defined HASH_Lisp_Obarray_D2757E61AD
+# error "Lisp_Obarray changed. See CHECK_STRUCTS comment in config.h."
+#endif
+ const struct Lisp_Obarray *in_oa = XOBARRAY (object);
+ struct Lisp_Obarray munged_oa = *in_oa;
+ struct Lisp_Obarray *oa = &munged_oa;
+ START_DUMP_PVEC (ctx, &oa->header, struct Lisp_Obarray, out);
+ dump_pseudovector_lisp_fields (ctx, &out->header, &oa->header);
+ DUMP_FIELD_COPY (out, oa, count);
+ DUMP_FIELD_COPY (out, oa, size_bits);
+ dump_field_fixup_later (ctx, out, oa, &oa->buckets);
+ dump_off offset = finish_dump_pvec (ctx, &out->header);
+ dump_remember_fixup_ptr_raw
+ (ctx,
+ offset + dump_offsetof (struct Lisp_Obarray, buckets),
+ dump_obarray_buckets (ctx, oa));
+ return offset;
+}
+
static dump_off
dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer)
{
@@ -2912,17 +2957,17 @@ dump_subr (struct dump_context *ctx, const struct
Lisp_Subr *subr)
dump_object_start (ctx, &out, sizeof (out));
DUMP_FIELD_COPY (&out, subr, header.size);
#ifdef HAVE_NATIVE_COMP
- bool native_comp = !NILP (subr->native_comp_u);
+ bool non_primitive = !NILP (subr->native_comp_u);
#else
- bool native_comp = false;
+ bool non_primitive = false;
#endif
- if (native_comp)
+ if (non_primitive)
out.function.a0 = NULL;
else
dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0);
DUMP_FIELD_COPY (&out, subr, min_args);
DUMP_FIELD_COPY (&out, subr, max_args);
- if (native_comp)
+ if (non_primitive)
{
dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name);
dump_remember_cold_op (ctx,
@@ -2947,7 +2992,7 @@ dump_subr (struct dump_context *ctx, const struct
Lisp_Subr *subr)
dump_field_lv (ctx, &out, subr, &subr->type, WEIGHT_NORMAL);
#endif
dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out));
- if (native_comp && ctx->flags.dump_object_contents)
+ if (non_primitive && ctx->flags.dump_object_contents)
/* We'll do the final addr relocation during VERY_LATE_RELOCS time
after the compilation units has been loaded. */
dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS],
@@ -3004,7 +3049,7 @@ dump_vectorlike (struct dump_context *ctx,
Lisp_Object lv,
dump_off offset)
{
-#if CHECK_STRUCTS && !defined HASH_pvec_type_D8A254BC70
+#if CHECK_STRUCTS && !defined HASH_pvec_type_2D583AC566
# error "pvec_type changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Vector *v = XVECTOR (lv);
@@ -3031,6 +3076,8 @@ dump_vectorlike (struct dump_context *ctx,
return dump_bool_vector(ctx, v);
case PVEC_HASH_TABLE:
return dump_hash_table (ctx, lv);
+ case PVEC_OBARRAY:
+ return dump_obarray (ctx, lv);
case PVEC_BUFFER:
return dump_buffer (ctx, XBUFFER (lv));
case PVEC_SUBR:
@@ -5593,10 +5640,7 @@ pdumper_load (const char *dump_filename, char *argv0)
struct dump_header header_buf = { 0 };
struct dump_header *header = &header_buf;
- struct dump_memory_map sections[NUMBER_DUMP_SECTIONS];
-
- /* Use memset instead of "= { 0 }" to work around GCC bug 105961. */
- memset (sections, 0, sizeof sections);
+ struct dump_memory_map sections[NUMBER_DUMP_SECTIONS] = { 0 };
const struct timespec start_time = current_timespec ();
char *dump_filename_copy;
diff --git a/src/pgtkterm.c b/src/pgtkterm.c
index b731f52983d..1ec6bfcda4e 100644
--- a/src/pgtkterm.c
+++ b/src/pgtkterm.c
@@ -5825,8 +5825,8 @@ note_mouse_movement (struct frame *frame,
/* Has the mouse moved off the glyph it was on at the last sighting? */
r = &dpyinfo->last_mouse_glyph;
if (frame != dpyinfo->last_mouse_glyph_frame
- || event->x < r->x || event->x >= r->x + r->width
- || event->y < r->y || event->y >= r->y + r->height)
+ || event->x < r->x || event->x >= r->x + (int) r->width
+ || event->y < r->y || event->y >= r->y + (int) r->height)
{
frame->mouse_moved = true;
dpyinfo->last_mouse_scroll_bar = NULL;
diff --git a/src/print.c b/src/print.c
index c6a3dba3163..76c577ec800 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1412,7 +1412,7 @@ print_preprocess (Lisp_Object obj)
&& SYMBOLP (obj)
&& !SYMBOL_INTERNED_P (obj)))
{ /* OBJ appears more than once. Let's remember that. */
- if (!FIXNUMP (num))
+ if (SYMBOLP (num)) /* In practice, nil or t. */
{
print_number_index++;
/* Negative number indicates it hasn't been printed yet. */
@@ -2078,6 +2078,16 @@ print_vectorlike_unreadable (Lisp_Object obj,
Lisp_Object printcharfun,
}
return;
+ case PVEC_OBARRAY:
+ {
+ struct Lisp_Obarray *o = XOBARRAY (obj);
+ /* FIXME: Would it make sense to print the actual symbols (up to
+ a limit)? */
+ int i = sprintf (buf, "#<obarray n=%u>", o->count);
+ strout (buf, i, i, printcharfun);
+ return;
+ }
+
/* Types handled earlier. */
case PVEC_NORMAL_VECTOR:
case PVEC_RECORD:
@@ -2265,6 +2275,11 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
goto next_obj;
}
}
+ else if (STRINGP (num))
+ {
+ strout (SSDATA (num), SCHARS (num), SBYTES (num), printcharfun);
+ goto next_obj;
+ }
}
print_depth++;
@@ -2554,11 +2569,6 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
goto next_obj;
case PVEC_SUB_CHAR_TABLE:
{
- /* Make each lowest sub_char_table start a new line.
- Otherwise we'll make a line extremely long, which
- results in slow redisplay. */
- if (XSUB_CHAR_TABLE (obj)->depth == 3)
- printchar ('\n', printcharfun);
print_c_string ("#^^[", printcharfun);
int n = sprintf (buf, "%d %d",
XSUB_CHAR_TABLE (obj)->depth,
@@ -2664,7 +2674,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
/* With the print-circle feature. */
Lisp_Object num = Fgethash (next, Vprint_number_table,
Qnil);
- if (FIXNUMP (num))
+ if (!(NILP (num) || EQ (num, Qt)))
{
print_c_string (" . ", printcharfun);
obj = next;
@@ -2928,7 +2938,10 @@ This variable should not be set with `setq'; bind it
with a `let' instead. */);
DEFVAR_LISP ("print-number-table", Vprint_number_table,
doc: /* A vector used internally to produce `#N=' labels and
`#N#' references.
The Lisp printer uses this vector to detect Lisp objects referenced more
-than once.
+than once. If an entry contains a number, then the corresponding key is
+referenced more than once: a positive sign indicates that it's already been
+printed, and the absolute value indicates the number to use when printing.
+If an entry contains a string, that string is printed instead.
When you bind `print-continuous-numbering' to t, you should probably
also bind `print-number-table' to nil. This ensures that the value of
diff --git a/src/process.c b/src/process.c
index ddab9ed6c01..48a2c0c8e53 100644
--- a/src/process.c
+++ b/src/process.c
@@ -5209,6 +5209,27 @@ wait_reading_process_output_1 (void)
{
}
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY \
+ && defined THREADS_ENABLED
+
+/* Wrapper around `android_select' that exposes a calling interface with
+ an extra argument for compatibility with `thread_pselect'. */
+
+static int
+android_select_wrapper (int nfds, fd_set *readfds, fd_set *writefds,
+ fd_set *exceptfds, const struct timespec *timeout,
+ const sigset_t *sigmask)
+{
+ /* sigmask is not supported. */
+ if (sigmask)
+ emacs_abort ();
+
+ return android_select (nfds, readfds, writefds, exceptfds,
+ (struct timespec *) timeout);
+}
+
+#endif /* HAVE_ANDROID && !ANDROID_STUBIFY && THREADS_ENABLED */
+
/* Read and dispose of subprocess output while waiting for timeout to
elapse and/or keyboard input to be available.
@@ -5701,13 +5722,19 @@ wait_reading_process_output (intmax_t time_limit, int
nsecs, int read_kbd,
timeout = short_timeout;
#endif
- /* Android doesn't support threads and requires using a
- replacement for pselect in android.c to poll for
- events. */
+ /* Android requires using a replacement for pselect in
+ android.c to poll for events. */
#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+#ifndef THREADS_ENABLED
nfds = android_select (max_desc + 1,
&Available, (check_write ? &Writeok : 0),
NULL, &timeout);
+#else /* THREADS_ENABLED */
+ nfds = thread_select (android_select_wrapper,
+ max_desc + 1,
+ &Available, (check_write ? &Writeok : 0),
+ NULL, &timeout, NULL);
+#endif /* THREADS_ENABLED */
#else
/* Non-macOS HAVE_GLIB builds call thread_select in
diff --git a/src/sfnt.c b/src/sfnt.c
index 6df43af4293..8598b052044 100644
--- a/src/sfnt.c
+++ b/src/sfnt.c
@@ -2798,12 +2798,6 @@ sfnt_decompose_compound_glyph (struct sfnt_glyph *glyph,
if (component->flags & 04000) /* SCALED_COMPONENT_OFFSET */
sfnt_transform_coordinates (component, &x, &y, 1,
0, 0);
-
- if (component->flags & 04) /* ROUND_XY_TO_GRID */
- {
- x = sfnt_round_fixed (x);
- y = sfnt_round_fixed (y);
- }
}
else
{
@@ -20800,8 +20794,8 @@ main (int argc, char **argv)
return 1;
}
-#define FANCY_PPEM 12
-#define EASY_PPEM 12
+#define FANCY_PPEM 18
+#define EASY_PPEM 18
interpreter = NULL;
head = sfnt_read_head_table (fd, font);
diff --git a/src/sfnt.h b/src/sfnt.h
index 5b01270e8ce..444b1dfe427 100644
--- a/src/sfnt.h
+++ b/src/sfnt.h
@@ -248,7 +248,7 @@ enum sfnt_macintosh_platform_specific_id
SFNT_MACINTOSH_GREEK = 6,
SFNT_MACINTOSH_RUSSIAN = 7,
SFNT_MACINTOSH_RSYMBOL = 8,
- SFNT_MACINTOSH_DEVANGARI = 9,
+ SFNT_MACINTOSH_DEVANAGARI = 9,
SFNT_MACINTOSH_GURMUKHI = 10,
SFNT_MACINTOSH_GUJARATI = 11,
SFNT_MACINTOSH_ORIYA = 12,
diff --git a/src/sfntfont.c b/src/sfntfont.c
index 860fc446184..3be770f650e 100644
--- a/src/sfntfont.c
+++ b/src/sfntfont.c
@@ -3308,7 +3308,7 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity,
ASET (font_object, FONT_TYPE_INDEX, sfnt_vendor_name);
ASET (font_object, FONT_FOUNDRY_INDEX, desc->designer);
ASET (font_object, FONT_FAMILY_INDEX, Fintern (desc->family, Qnil));
- ASET (font_object, FONT_ADSTYLE_INDEX, Qnil);
+ ASET (font_object, FONT_ADSTYLE_INDEX, desc->adstyle);
ASET (font_object, FONT_REGISTRY_INDEX,
sfntfont_registry_for_desc (desc));
@@ -3326,8 +3326,6 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity,
FONT_SET_STYLE (font_object, FONT_SLANT_INDEX,
make_fixnum (desc->slant));
- ASET (font_object, FONT_ADSTYLE_INDEX, Qnil);
-
/* Clear various offsets. */
font_info->font.baseline_offset = 0;
font_info->font.relative_compose = 0;
@@ -3412,7 +3410,7 @@ sfntfont_open (struct frame *f, Lisp_Object font_entity,
AREF (tem, 3));
FONT_SET_STYLE (font_object, FONT_SLANT_INDEX,
AREF (tem, 4));
- ASET (font_object, FONT_ADSTYLE_INDEX, Qnil);
+ ASET (font_object, FONT_ADSTYLE_INDEX, AREF (tem, 1));
}
}
diff --git a/src/term.c b/src/term.c
index 447876d288a..3fa244be824 100644
--- a/src/term.c
+++ b/src/term.c
@@ -1631,8 +1631,19 @@ produce_glyphs (struct it *it)
it->pixel_width = it->nglyphs = 0;
else if (it->char_to_display == '\t')
{
+ /* wrap-prefix strings are prepended to continuation lines, so
+ the width of tab characters inside should be computed from
+ the start of this screen line rather than as a product of the
+ total width of the physical line being wrapped. */
int absolute_x = (it->current_x
- + it->continuation_lines_width);
+ + (it->string_from_prefix_prop_p
+ /* Subtract the width of the
+ prefix from it->current_x if
+ it exists. */
+ ? 0 : (it->continuation_lines_width
+ ? (it->continuation_lines_width
+ - it->wrap_prefix_width)
+ : 0)));
int x0 = absolute_x;
/* Adjust for line numbers. */
if (!NILP (Vdisplay_line_numbers) && it->line_number_produced_p)
@@ -1704,7 +1715,13 @@ produce_glyphs (struct it *it)
/* Advance current_x by the pixel width as a convenience for
the caller. */
if (it->area == TEXT_AREA)
- it->current_x += it->pixel_width;
+ {
+ it->current_x += it->pixel_width;
+
+ if (it->continuation_lines_width
+ && it->string_from_prefix_prop_p)
+ it->wrap_prefix_width = it->current_x;
+ }
it->ascent = it->max_ascent = it->phys_ascent = it->max_phys_ascent = 0;
it->descent = it->max_descent = it->phys_descent = it->max_phys_descent = 1;
#endif
diff --git a/src/textconv.c b/src/textconv.c
index 0d35ec19c55..0941848dd09 100644
--- a/src/textconv.c
+++ b/src/textconv.c
@@ -1705,11 +1705,8 @@ set_composing_region (struct frame *f, ptrdiff_t start,
{
struct text_conversion_action *action, **last;
- if (start > MOST_POSITIVE_FIXNUM)
- start = MOST_POSITIVE_FIXNUM;
-
- if (end > MOST_POSITIVE_FIXNUM)
- end = MOST_POSITIVE_FIXNUM;
+ start = min (start, MOST_POSITIVE_FIXNUM);
+ end = min (end, MOST_POSITIVE_FIXNUM);
action = xmalloc (sizeof *action);
action->operation = TEXTCONV_SET_COMPOSING_REGION;
@@ -1734,8 +1731,7 @@ textconv_set_point_and_mark (struct frame *f, ptrdiff_t
point,
{
struct text_conversion_action *action, **last;
- if (point > MOST_POSITIVE_FIXNUM)
- point = MOST_POSITIVE_FIXNUM;
+ point = min (point, MOST_POSITIVE_FIXNUM);
action = xmalloc (sizeof *action);
action->operation = TEXTCONV_SET_POINT_AND_MARK;
diff --git a/src/thread.c b/src/thread.c
index 040ca39511e..2f5d7a08838 100644
--- a/src/thread.c
+++ b/src/thread.c
@@ -106,6 +106,12 @@ post_acquire_global_lock (struct thread_state *self)
{
struct thread_state *prev_thread = current_thread;
+ /* Switch the JNI interface pointer to the environment assigned to the
+ current thread. */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ android_java_env = self->java_env;
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
/* Do this early on, so that code below could signal errors (e.g.,
unbind_for_thread_switch might) correctly, because we are already
running in the context of the thread pointed by SELF. */
@@ -126,6 +132,12 @@ post_acquire_global_lock (struct thread_state *self)
set_buffer_internal_2 (current_buffer);
}
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* This step is performed in android_select when built without
+ threads. */
+ android_check_query ();
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
/* We could have been signaled while waiting to grab the global lock
for the first time since this thread was created, in which case
we didn't yet have the opportunity to set up the handlers. Delay
@@ -756,6 +768,11 @@ run_thread (void *state)
struct thread_state *self = state;
struct thread_state **iter;
+#ifdef THREADS_ENABLED
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ jint rc;
+#endif /* #if defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+#endif /* THREADS_ENABLED */
#ifdef HAVE_NS
/* Allocate an autorelease pool in case this thread calls any
@@ -766,6 +783,16 @@ run_thread (void *state)
void *pool = ns_alloc_autorelease_pool ();
#endif
+#ifdef THREADS_ENABLED
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ rc
+ = (*android_jvm)->AttachCurrentThread (android_jvm, &self->java_env,
+ NULL);
+ if (rc != JNI_OK)
+ emacs_abort ();
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+#endif /* THREADS_ENABLED */
+
self->m_stack_bottom = self->stack_top = &stack_pos.c;
self->thread_id = sys_thread_self ();
@@ -812,6 +839,14 @@ run_thread (void *state)
ns_release_autorelease_pool (pool);
#endif
+#ifdef THREADS_ENABLED
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ rc = (*android_jvm)->DetachCurrentThread (android_jvm);
+ if (rc != JNI_OK)
+ emacs_abort ();
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+#endif /* THREADS_ENABLED */
+
/* Unlink this thread from the list of all threads. Note that we
have to do this very late, after broadcasting our death.
Otherwise the GC may decide to reap the thread_state object,
@@ -1131,6 +1166,10 @@ init_threads (void)
sys_mutex_init (&global_lock);
sys_mutex_lock (&global_lock);
current_thread = &main_thread.s;
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ current_thread->java_env = android_java_env;
+#endif /* defined HAVE_ANDROID && !defined ANDROID_STUBIFY */
+
main_thread.s.thread_id = sys_thread_self ();
init_bc_thread (&main_thread.s.bc);
}
diff --git a/src/thread.h b/src/thread.h
index 6ce2b7f30df..1844cf03967 100644
--- a/src/thread.h
+++ b/src/thread.h
@@ -30,6 +30,12 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
#include <signal.h> /* sigset_t */
#endif
+#ifdef HAVE_ANDROID
+#ifndef ANDROID_STUBIFY
+#include "android.h"
+#endif /* ANDROID_STUBIFY */
+#endif /* HAVE_ANDROID */
+
#include "sysselect.h" /* FIXME */
#include "systhread.h"
@@ -84,6 +90,11 @@ struct thread_state
Lisp_Object event_object;
/* event_object must be the last Lisp field. */
+#if defined HAVE_ANDROID && !defined ANDROID_STUBIFY
+ /* Pointer to an object to call Java functions through. */
+ JNIEnv *java_env;
+#endif /* HAVE_ANDROID && !ANDROID_STUBIFY */
+
/* An address near the bottom of the stack.
Tells GC how to save a copy of the stack. */
char const *m_stack_bottom;
diff --git a/src/timefns.c b/src/timefns.c
index 1541583b485..0ecbb6e6793 100644
--- a/src/timefns.c
+++ b/src/timefns.c
@@ -225,7 +225,7 @@ tzlookup (Lisp_Object zone, bool settz)
if (NILP (zone))
return local_tz;
- else if (BASE_EQ (zone, make_fixnum (0)) || BASE2_EQ (zone, Qt))
+ else if (BASE_EQ (zone, make_fixnum (0)) || EQ (zone, Qt))
{
zone_string = "UTC0";
new_tz = utc_tz;
@@ -234,7 +234,7 @@ tzlookup (Lisp_Object zone, bool settz)
{
bool plain_integer = FIXNUMP (zone);
- if (BASE2_EQ (zone, Qwall))
+ if (EQ (zone, Qwall))
zone_string = 0;
else if (STRINGP (zone))
zone_string = SSDATA (ENCODE_SYSTEM (zone));
@@ -1548,7 +1548,7 @@ usage: (decode-time &optional TIME ZONE FORM) */)
/* Compute SEC from LOCAL_TM.tm_sec and HZ. */
Lisp_Object hz = lt.hz, sec;
- if (BASE_EQ (hz, make_fixnum (1)) || !BASE2_EQ (form, Qt))
+ if (BASE_EQ (hz, make_fixnum (1)) || !EQ (form, Qt))
sec = make_fixnum (local_tm.tm_sec);
else
{
@@ -1765,10 +1765,8 @@ but new code should not rely on it. */)
well, since we accept it as input? */
struct lisp_time t;
enum timeform input_form = decode_lisp_time (time, false, &t, 0);
- if (NILP (form))
- form = current_time_list ? Qlist : Qt;
- if (symbols_with_pos_enabled && SYMBOL_WITH_POS_P (form))
- form = SYMBOL_WITH_POS_SYM (form);
+ form = (!NILP (form) ? maybe_remove_pos_from_symbol (form)
+ : current_time_list ? Qlist : Qt);
if (BASE_EQ (form, Qlist))
return ticks_hz_list4 (t.ticks, t.hz);
if (BASE_EQ (form, Qinteger))
diff --git a/src/treesit.c b/src/treesit.c
index 12915ea9a10..d86ab501187 100644
--- a/src/treesit.c
+++ b/src/treesit.c
@@ -3275,11 +3275,11 @@ treesit_traverse_child_helper (TSTreeCursor *cursor,
static Lisp_Object
treesit_traverse_get_predicate (Lisp_Object thing, Lisp_Object language)
{
- Lisp_Object cons = assq_no_quit (language, Vtreesit_thing_settings);
+ Lisp_Object cons = assq_no_signal (language, Vtreesit_thing_settings);
if (NILP (cons))
return Qnil;
Lisp_Object definitions = XCDR (cons);
- Lisp_Object entry = assq_no_quit (thing, definitions);
+ Lisp_Object entry = assq_no_signal (thing, definitions);
if (NILP (entry))
return Qnil;
/* ENTRY looks like (THING PRED). */
diff --git a/src/verbose.mk.in b/src/verbose.mk.in
index e72c182f276..6efb6b9416b 100644
--- a/src/verbose.mk.in
+++ b/src/verbose.mk.in
@@ -53,38 +53,39 @@ have_working_info = $(filter notintermediate,$(value
.FEATURES))
# The workaround is done only for AM_V_ELC and AM_V_ELN,
# since the bug is not annoying elsewhere.
-AM_V_AR = @$(info $ AR $@)
+. :=
+AM_V_AR = @$(info $. AR $@)
AM_V_at = @
-AM_V_CC = @$(info $ CC $@)
-AM_V_CXX = @$(info $ CXX $@)
-AM_V_CCLD = @$(info $ CCLD $@)
-AM_V_CXXLD = @$(info $ CXXLD $@)
+AM_V_CC = @$(info $. CC $@)
+AM_V_CXX = @$(info $. CXX $@)
+AM_V_CCLD = @$(info $. CCLD $@)
+AM_V_CXXLD = @$(info $. CXXLD $@)
ifeq ($(HAVE_NATIVE_COMP)-$(NATIVE_DISABLED)-$(ANCIENT),yes--)
ifneq (,$(have_working_info))
-AM_V_ELC = @$(info $ ELC+ELN $@)
-AM_V_ELN = @$(info $ ELN $@)
+AM_V_ELC = @$(info $. ELC+ELN $@)
+AM_V_ELN = @$(info $. ELN $@)
else
AM_V_ELC = @echo " ELC+ELN " $@;
AM_V_ELN = @echo " ELN " $@;
endif
else
ifneq (,$(have_working_info))
-AM_V_ELC = @$(info $ ELC $@)
+AM_V_ELC = @$(info $. ELC $@)
else
AM_V_ELC = @echo " ELC " $@;
endif
AM_V_ELN =
endif
-AM_V_GEN = @$(info $ GEN $@)
-AM_V_GLOBALS = @$(info $ GEN globals.h)
+AM_V_GEN = @$(info $. GEN $@)
+AM_V_GLOBALS = @$(info $. GEN globals.h)
AM_V_NO_PD = --no-print-directory
-AM_V_RC = @$(info $ RC $@)
+AM_V_RC = @$(info $. RC $@)
# These are used for the Android port.
-AM_V_JAVAC = @$(info $ JAVAC $@)
-AM_V_D8 = @$(info $ D8 $@)
-AM_V_AAPT = @$(info $ AAPT $@)
+AM_V_JAVAC = @$(info $. JAVAC $@)
+AM_V_D8 = @$(info $. D8 $@)
+AM_V_AAPT = @$(info $. AAPT $@)
AM_V_SILENT = @
endif
diff --git a/src/window.c b/src/window.c
index 915f591221d..0c84b4f4bf3 100644
--- a/src/window.c
+++ b/src/window.c
@@ -4151,6 +4151,8 @@ set_window_buffer (Lisp_Object window, Lisp_Object buffer,
buffer);
w->start_at_line_beg = false;
w->force_start = false;
+ /* Flush the base_line cache since it applied to another buffer. */
+ w->base_line_number = 0;
}
wset_redisplay (w);
@@ -5378,7 +5380,14 @@ grow_mini_window (struct window *w, int delta)
grow = call3 (Qwindow__resize_root_window_vertically,
root, make_fixnum (- delta), Qt);
- if (FIXNUMP (grow) && window_resize_check (r, false))
+ if (FIXNUMP (grow)
+ /* It might be impossible to resize the window, in which case
+ calling resize_mini_window_apply will set off an infinite
+ loop where the redisplay cycle so forced returns to
+ resize_mini_window, making endless attempts to expand the
+ minibuffer window to this impossible size. (bug#69140) */
+ && XFIXNUM (grow) != 0
+ && window_resize_check (r, false))
resize_mini_window_apply (w, -XFIXNUM (grow));
}
}
diff --git a/src/xdisp.c b/src/xdisp.c
index 19f176459c7..d03769e2a31 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -2508,7 +2508,7 @@ get_glyph_string_clip_rects (struct glyph_string *s,
NativeRectangle *rects, int
r.x = s->clip_head->x;
}
if (s->clip_tail)
- if (r.x + r.width > s->clip_tail->x + s->clip_tail->background_width)
+ if (r.x + (int) r.width > s->clip_tail->x + s->clip_tail->background_width)
{
if (s->clip_tail->x + s->clip_tail->background_width >= r.x)
r.width = s->clip_tail->x + s->clip_tail->background_width - r.x;
@@ -2588,7 +2588,7 @@ get_glyph_string_clip_rects (struct glyph_string *s,
NativeRectangle *rects, int
height = max (FRAME_LINE_HEIGHT (s->f), glyph->ascent +
glyph->descent);
if (height < r.height)
{
- max_y = r.y + r.height;
+ max_y = r.y + (int) r.height;
r.y = min (max_y, max (r.y, s->ybase + glyph->descent - height));
r.height = min (max_y - r.y, height);
}
@@ -2629,7 +2629,7 @@ get_glyph_string_clip_rects (struct glyph_string *s,
NativeRectangle *rects, int
if (s->for_overlaps & OVERLAPS_PRED)
{
rs[i] = r;
- if (r.y + r.height > row_y)
+ if (r.y + (int) r.height > row_y)
{
if (r.y < row_y)
rs[i].height = row_y - r.y;
@@ -2643,10 +2643,10 @@ get_glyph_string_clip_rects (struct glyph_string *s,
NativeRectangle *rects, int
rs[i] = r;
if (r.y < row_y + s->row->visible_height)
{
- if (r.y + r.height > row_y + s->row->visible_height)
+ if (r.y + (int) r.height > row_y + s->row->visible_height)
{
rs[i].y = row_y + s->row->visible_height;
- rs[i].height = r.y + r.height - rs[i].y;
+ rs[i].height = r.y + (int) r.height - rs[i].y;
}
else
rs[i].height = 0;
@@ -2831,7 +2831,7 @@ remember_mouse_glyph (struct frame *f, int gx, int gy,
NativeRectangle *rect)
text_glyph:
gr = 0; gy = 0;
for (; r <= end_row && r->enabled_p; ++r)
- if (r->y + r->height > y)
+ if (r->y + (int) r->height > y)
{
gr = r; gy = r->y;
break;
@@ -2931,7 +2931,7 @@ remember_mouse_glyph (struct frame *f, int gx, int gy,
NativeRectangle *rect)
row_glyph:
gr = 0, gy = 0;
for (; r <= end_row && r->enabled_p; ++r)
- if (r->y + r->height > y)
+ if (r->y + (int) r->height > y)
{
gr = r; gy = r->y;
break;
@@ -3821,7 +3821,7 @@ start_display (struct it *it, struct window *w, struct
text_pos pos)
it->current_y = first_y;
it->vpos = 0;
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
}
}
}
@@ -4345,10 +4345,7 @@ compute_stop_pos (struct it *it)
}
}
- if (it->cmp_it.id < 0
- && (STRINGP (it->string)
- || ((!it->bidi_p || it->bidi_it.scan_dir >= 0)
- && it->cmp_it.stop_pos <= IT_CHARPOS (*it))))
+ if (it->cmp_it.id < 0)
{
ptrdiff_t stoppos = it->end_charpos;
@@ -4357,7 +4354,9 @@ compute_stop_pos (struct it *it)
characters to that position. */
if (it->bidi_p && it->bidi_it.scan_dir < 0)
stoppos = -1;
- else if (cmp_limit_pos > 0)
+ else if (!STRINGP (it->string)
+ && it->cmp_it.stop_pos <= IT_CHARPOS (*it)
+ && cmp_limit_pos > 0)
stoppos = cmp_limit_pos;
/* Force composition_compute_stop_pos avoid the costly search
for static compositions, since those were already found by
@@ -5062,31 +5061,169 @@ handle_invisible_prop (struct it *it)
{
enum prop_handled handled = HANDLED_NORMALLY;
int invis;
- Lisp_Object prop;
+ ptrdiff_t curpos, endpos;
+ Lisp_Object prop, pos, overlay;
+ /* Get the value of the invisible text property at the current
+ position. Value will be nil if there is no such property. */
if (STRINGP (it->string))
{
- Lisp_Object end_charpos, limit;
+ curpos = IT_STRING_CHARPOS (*it);
+ endpos = SCHARS (it->string);
+ pos = make_fixnum (curpos);
+ prop = Fget_text_property (pos, Qinvisible, it->string);
+ }
+ else /* buffer */
+ {
+ curpos = IT_CHARPOS (*it);
+ endpos = ZV;
+ pos = make_fixnum (curpos);
+ prop = get_char_property_and_overlay (pos, Qinvisible, it->window,
+ &overlay);
+ }
- /* Get the value of the invisible text property at the
- current position. Value will be nil if there is no such
- property. */
- end_charpos = make_fixnum (IT_STRING_CHARPOS (*it));
- prop = Fget_text_property (end_charpos, Qinvisible, it->string);
- invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ /* Do we have anything to do here? */
+ invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ if (invis == 0 || curpos >= it->end_charpos)
+ return handled;
- if (invis != 0 && IT_STRING_CHARPOS (*it) < it->end_charpos)
+ /* If not bidi, or the bidi iteration is at base paragraph level, we
+ can use a faster method; otherwise we need to check invisibility
+ of every character while bidi-iterating out of invisible text. */
+ bool slow = it->bidi_p && !BIDI_AT_BASE_LEVEL (it->bidi_it);
+ /* Record whether we have to display an ellipsis for the
+ invisible text. */
+ bool display_ellipsis_p = (invis == 2);
+
+ handled = HANDLED_RECOMPUTE_PROPS;
+
+ if (slow)
+ {
+ if (it->bidi_it.first_elt && it->bidi_it.charpos < endpos)
+ bidi_paragraph_init (it->paragraph_embedding, &it->bidi_it, true);
+
+ if (STRINGP (it->string))
+ {
+ bool done = false;
+ /* Bidi-iterate out of the invisible part of the string. */
+ do
+ {
+ bidi_move_to_visually_next (&it->bidi_it);
+ if (it->bidi_it.charpos < 0 || it->bidi_it.charpos >= endpos)
+ done = true;
+ else
+ {
+ pos = make_fixnum (it->bidi_it.charpos);
+ prop = Fget_text_property (pos, Qinvisible, it->string);
+ invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ /* If there are adjacent invisible texts, don't lose
+ the second one's ellipsis. */
+ if (invis == 2)
+ display_ellipsis_p = true;
+ }
+ }
+ while (!done && invis != 0);
+
+ if (display_ellipsis_p)
+ it->ellipsis_p = true;
+ IT_STRING_CHARPOS (*it) = it->bidi_it.charpos;
+ IT_STRING_BYTEPOS (*it) = it->bidi_it.bytepos;
+ if (IT_STRING_BYTEPOS (*it) >= endpos)
+ {
+ /* The rest of the string is invisible. If this is an
+ overlay string, proceed with the next overlay string
+ or whatever comes and return a character from there. */
+ if (it->current.overlay_string_index >= 0
+ && !display_ellipsis_p)
+ {
+ next_overlay_string (it);
+ /* Don't check for overlay strings when we just
+ finished processing them. */
+ handled = HANDLED_OVERLAY_STRING_CONSUMED;
+ }
+ }
+ }
+ else
{
- /* Record whether we have to display an ellipsis for the
- invisible text. */
- bool display_ellipsis_p = (invis == 2);
- ptrdiff_t len, endpos;
+ bool done = false;
+ /* Bidi-iterate out of the invisible text. */
+ do
+ {
+ bidi_move_to_visually_next (&it->bidi_it);
+ if (it->bidi_it.charpos < BEGV || it->bidi_it.charpos >= endpos)
+ done = true;
+ else
+ {
+ pos = make_fixnum (it->bidi_it.charpos);
+ prop = Fget_char_property (pos, Qinvisible, it->window);
+ invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ /* If there are adjacent invisible texts, don't lose
+ the second one's ellipsis. */
+ if (invis == 2)
+ display_ellipsis_p = true;
+ }
+ }
+ while (!done && invis != 0);
+
+ IT_CHARPOS (*it) = it->bidi_it.charpos;
+ IT_BYTEPOS (*it) = it->bidi_it.bytepos;
+ if (display_ellipsis_p)
+ {
+ /* Make sure that the glyphs of the ellipsis will get
+ correct `charpos' values. See below for detailed
+ explanation why this is needed. */
+ it->position.charpos = IT_CHARPOS (*it) - 1;
+ it->position.bytepos = CHAR_TO_BYTE (it->position.charpos);
+ }
+ /* If there are before-strings at the start of invisible
+ text, and the text is invisible because of a text
+ property, arrange to show before-strings because 20.x did
+ it that way. (If the text is invisible because of an
+ overlay property instead of a text property, this is
+ already handled in the overlay code.) */
+ if (NILP (overlay)
+ && get_overlay_strings (it, it->stop_charpos))
+ {
+ handled = HANDLED_RECOMPUTE_PROPS;
+ if (it->sp > 0)
+ {
+ it->stack[it->sp - 1].display_ellipsis_p = display_ellipsis_p;
+ /* The call to get_overlay_strings above recomputes
+ it->stop_charpos, but it only considers changes
+ in properties and overlays beyond iterator's
+ current position. This causes us to miss changes
+ that happen exactly where the invisible property
+ ended. So we play it safe here and force the
+ iterator to check for potential stop positions
+ immediately after the invisible text. Note that
+ if get_overlay_strings returns true, it
+ normally also pushed the iterator stack, so we
+ need to update the stop position in the slot
+ below the current one. */
+ it->stack[it->sp - 1].stop_charpos
+ = CHARPOS (it->stack[it->sp - 1].current.pos);
+ }
+ }
+ else if (display_ellipsis_p)
+ {
+ it->ellipsis_p = true;
+ /* Let the ellipsis display before
+ considering any properties of the following char.
+ Fixes jasonr@gnu.org 01 Oct 07 bug. */
+ handled = HANDLED_RETURN;
+ }
+ }
+ }
+ else if (STRINGP (it->string))
+ {
+ Lisp_Object end_charpos = pos, limit;
- handled = HANDLED_RECOMPUTE_PROPS;
+ if (invis != 0 && IT_STRING_CHARPOS (*it) < it->end_charpos)
+ {
+ ptrdiff_t len = endpos;
/* Get the position at which the next visible text can be
found in IT->string, if any. */
- endpos = len = SCHARS (it->string);
XSETINT (limit, len);
do
{
@@ -5137,7 +5274,7 @@ handle_invisible_prop (struct it *it)
IT_STRING_CHARPOS (*it) = it->bidi_it.charpos;
IT_STRING_BYTEPOS (*it) = it->bidi_it.bytepos;
- if (IT_CHARPOS (*it) >= endpos)
+ if (IT_STRING_CHARPOS (*it) >= endpos)
it->prev_stop = endpos;
}
else
@@ -5167,27 +5304,14 @@ handle_invisible_prop (struct it *it)
}
}
}
- else
+ else /* we are iterating over buffer text at base paragraph level */
{
- ptrdiff_t newpos, next_stop, start_charpos, tem;
- Lisp_Object pos, overlay;
-
- /* First of all, is there invisible text at this position? */
- tem = start_charpos = IT_CHARPOS (*it);
- pos = make_fixnum (tem);
- prop = get_char_property_and_overlay (pos, Qinvisible, it->window,
- &overlay);
- invis = TEXT_PROP_MEANS_INVISIBLE (prop);
+ ptrdiff_t newpos, next_stop, tem = curpos;
+ Lisp_Object pos;
/* If we are on invisible text, skip over it. */
- if (invis != 0 && start_charpos < it->end_charpos)
+ if (invis != 0 && curpos < it->end_charpos)
{
- /* Record whether we have to display an ellipsis for the
- invisible text. */
- bool display_ellipsis_p = invis == 2;
-
- handled = HANDLED_RECOMPUTE_PROPS;
-
/* Loop skipping over invisible text. The loop is left at
ZV or with IT on the first char being visible again. */
do
@@ -5487,9 +5611,6 @@ display_min_width (struct it *it, ptrdiff_t bufpos,
if (!NILP (it->min_width_property)
&& !EQ (width_spec, it->min_width_property))
{
- if (!it->glyph_row)
- return;
-
/* When called from display_string (i.e., the mode line),
we're being called with a string as the object, and we
may be called with many sub-strings belonging to the same
@@ -5532,7 +5653,13 @@ display_min_width (struct it *it, ptrdiff_t bufpos,
it->object = list3 (Qspace, QCwidth, w);
produce_stretch_glyph (it);
if (it->area == TEXT_AREA)
- it->current_x += it->pixel_width;
+ {
+ it->current_x += it->pixel_width;
+
+ if (it->continuation_lines_width
+ && it->string_from_prefix_prop_p)
+ it->wrap_prefix_width = it->current_x;
+ }
it->min_width_property = Qnil;
}
}
@@ -9733,6 +9860,13 @@ move_it_in_display_line_to (struct it *it,
ptrdiff_t prev_pos = IT_CHARPOS (*it);
bool saw_smaller_pos = prev_pos < to_charpos;
bool line_number_pending = false;
+ int this_line_subject_to_line_prefix = 0;
+
+#ifdef GLYPH_DEBUG
+ /* atx_flag, atpos_flag and wrap_flag are assigned but never used;
+ these hold information useful while debugging. */
+ int atx_flag, atpos_flag, wrap_flag;
+#endif /* GLYPH_DEBUG */
/* Don't produce glyphs in produce_glyphs. */
saved_glyph_row = it->glyph_row;
@@ -9798,6 +9932,11 @@ move_it_in_display_line_to (struct it *it,
/* If there's a line-/wrap-prefix, handle it, if we didn't already. */
if (it->area == TEXT_AREA && !it->string_from_prefix_prop_p)
handle_line_prefix (it);
+
+ /* Save whether this line has received a wrap prefix, as this
+ affects whether Emacs attempts to move glyphs into
+ continuation lines. */
+ this_line_subject_to_line_prefix = it->string_from_prefix_prop_p;
}
if (IT_CHARPOS (*it) < CHARPOS (this_line_min_pos))
@@ -9841,10 +9980,15 @@ move_it_in_display_line_to (struct it *it,
break;
}
else if (it->line_wrap == WORD_WRAP && atpos_it.sp < 0)
- /* If wrap_it is valid, the current position might be in a
- word that is wrapped. So, save the iterator in
- atpos_it and continue to see if wrapping happens. */
- SAVE_IT (atpos_it, *it, atpos_data);
+ {
+ /* If wrap_it is valid, the current position might be in
+ a word that is wrapped. So, save the iterator in
+ atpos_it and continue to see if wrapping happens. */
+ SAVE_IT (atpos_it, *it, atpos_data);
+#ifdef GLYPH_DEBUG
+ atpos_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
+ }
}
/* Stop when ZV reached.
@@ -9906,6 +10050,9 @@ move_it_in_display_line_to (struct it *it,
}
/* Otherwise, we can wrap here. */
SAVE_IT (wrap_it, *it, wrap_data);
+#ifdef GLYPH_DEBUG
+ wrap_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
}
/* Update may_wrap for the next iteration. */
may_wrap = next_may_wrap;
@@ -9984,6 +10131,9 @@ move_it_in_display_line_to (struct it *it,
{
SAVE_IT (atpos_it, *it, atpos_data);
IT_RESET_X_ASCENT_DESCENT (&atpos_it);
+#ifdef GLYPH_DEBUG
+ atpos_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
}
}
else
@@ -9998,6 +10148,9 @@ move_it_in_display_line_to (struct it *it,
{
SAVE_IT (atx_it, *it, atx_data);
IT_RESET_X_ASCENT_DESCENT (&atx_it);
+#ifdef GLYPH_DEBUG
+ atx_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
}
}
}
@@ -10012,12 +10165,27 @@ move_it_in_display_line_to (struct it *it,
&& FRAME_WINDOW_P (it->f)
&& ((it->bidi_p && it->bidi_it.paragraph_dir == R2L)
? WINDOW_LEFT_FRINGE_WIDTH (it->w)
- : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))
+ : WINDOW_RIGHT_FRINGE_WIDTH (it->w))))
+ /* There is no line prefix, next to which the
+ iterator _must_ produce a minimum of one actual
+ glyph. */
+ && (!this_line_subject_to_line_prefix
+ /* Or this is the second glyph to be produced
+ beyond the confines of the line. */
+ || (i != 0
+ && (x > it->last_visible_x
+ || (x == it->last_visible_x
+ && FRAME_WINDOW_P (it->f)
+ && ((it->bidi_p
+ && it->bidi_it.paragraph_dir == R2L)
+ ? WINDOW_LEFT_FRINGE_WIDTH (it->w)
+ : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))))
{
bool moved_forward = false;
if (/* IT->hpos == 0 means the very first glyph
- doesn't fit on the line, e.g. a wide image. */
+ doesn't fit on the line, e.g. a wide
+ image. */
it->hpos == 0
|| (new_x == it->last_visible_x
&& FRAME_WINDOW_P (it->f)))
@@ -10078,6 +10246,9 @@ move_it_in_display_line_to (struct it *it,
SAVE_IT (atpos_it, *it, atpos_data);
atpos_it.current_x = x_before_this_char;
atpos_it.hpos = hpos_before_this_char;
+#ifdef GLYPH_DEBUG
+ atpos_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
}
}
@@ -10175,6 +10346,9 @@ move_it_in_display_line_to (struct it *it,
if (it->line_wrap == WORD_WRAP && atpos_it.sp < 0)
{
SAVE_IT (atpos_it, *it, atpos_data);
+#ifdef GLYPH_DEBUG
+ atpos_flag = this_line_subject_to_line_prefix;
+#endif /* GLYPH_DEBUG */
IT_RESET_X_ASCENT_DESCENT (&atpos_it);
}
}
@@ -10273,24 +10447,24 @@ move_it_in_display_line_to (struct it *it,
if (it->method == GET_FROM_BUFFER)
prev_pos = IT_CHARPOS (*it);
- /* Detect overly-wide wrap-prefixes made of (space ...) display
- properties. When such a wrap prefix reaches past the right
- margin of the window, we need to avoid the call to
- set_iterator_to_next below, so that it->line_wrap is left at
- its TRUNCATE value wisely set by handle_line_prefix.
- Otherwise, set_iterator_to_next will pop the iterator stack,
- restore it->line_wrap, and we might miss the opportunity to
- exit the loop and return. */
- bool overwide_wrap_prefix =
- CONSP (it->object) && EQ (XCAR (it->object), Qspace)
- && it->sp > 0 && it->method == GET_FROM_STRETCH
- && it->current_x >= it->last_visible_x
- && it->continuation_lines_width > 0
- && it->line_wrap == TRUNCATE && it->stack[0].line_wrap != TRUNCATE;
- /* The current display element has been consumed. Advance
- to the next. */
- if (!overwide_wrap_prefix)
- set_iterator_to_next (it, true);
+ /* The current display element has been consumed. Advance to
+ the next. */
+ set_iterator_to_next (it, true);
+
+ /* If IT has just finished producing glyphs for the wrap prefix
+ and is proceeding to the next method, there might not be
+ sufficient space remaining in this line to accommodate its
+ glyphs, and one real glyph must be produced to prevent an
+ infinite loop. Next, clear this flag if such a glyph has
+ already been produced. */
+
+ if (this_line_subject_to_line_prefix == 1
+ && !it->string_from_prefix_prop_p)
+ this_line_subject_to_line_prefix = 2;
+ else if (this_line_subject_to_line_prefix == 2
+ && !it->string_from_prefix_prop_p)
+ this_line_subject_to_line_prefix = 0;
+
if (IT_CHARPOS (*it) < CHARPOS (this_line_min_pos))
SET_TEXT_POS (this_line_min_pos, IT_CHARPOS (*it), IT_BYTEPOS (*it));
if (IT_CHARPOS (*it) < to_charpos)
@@ -10374,11 +10548,26 @@ move_it_in_display_line_to (struct it *it,
&& wrap_it.sp >= 0
&& ((atpos_it.sp >= 0 && wrap_it.current_x < atpos_it.current_x)
|| (atx_it.sp >= 0 && wrap_it.current_x < atx_it.current_x)))
- RESTORE_IT (it, &wrap_it, wrap_data);
+ {
+#ifdef GLYPH_DEBUG
+ this_line_subject_to_line_prefix = wrap_flag;
+#endif /* GLYPH_DEBUG */
+ RESTORE_IT (it, &wrap_it, wrap_data);
+ }
else if (atpos_it.sp >= 0)
- RESTORE_IT (it, &atpos_it, atpos_data);
+ {
+#ifdef GLYPH_DEBUG
+ this_line_subject_to_line_prefix = atpos_flag;
+#endif /* GLYPH_DEBUG */
+ RESTORE_IT (it, &atpos_it, atpos_data);
+ }
else if (atx_it.sp >= 0)
- RESTORE_IT (it, &atx_it, atx_data);
+ {
+#ifdef GLYPH_DEBUG
+ this_line_subject_to_line_prefix = atx_flag;
+#endif /* GLYPH_DEBUG */
+ RESTORE_IT (it, &atx_it, atx_data);
+ }
done:
@@ -10452,13 +10641,9 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int
to_x, int to_y, int to_vpos
int line_height, line_start_x = 0, reached = 0;
int max_current_x = 0;
void *backup_data = NULL;
- ptrdiff_t orig_charpos = -1;
- enum it_method orig_method = NUM_IT_METHODS;
for (;;)
{
- orig_charpos = IT_CHARPOS (*it);
- orig_method = it->method;
if (op & MOVE_TO_VPOS)
{
/* If no TO_CHARPOS and no TO_X specified, stop at the
@@ -10730,21 +10915,7 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int
to_x, int to_y, int to_vpos
}
}
else
- {
- /* Make sure we do advance, otherwise we might infloop.
- This could happen when the first display element is
- wider than the window, or if we have a wrap-prefix
- that doesn't leave enough space after it to display
- even a single character. We only do this for moving
- through buffer text, as with display/overlay strings
- we'd need to also compare it->object's, and this is
- unlikely to happen in that case anyway. */
- if (IT_CHARPOS (*it) == orig_charpos
- && it->method == orig_method
- && orig_method == GET_FROM_BUFFER)
- set_iterator_to_next (it, false);
- it->continuation_lines_width += it->current_x;
- }
+ it->continuation_lines_width += it->current_x;
break;
default:
@@ -10753,6 +10924,7 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int
to_x, int to_y, int to_vpos
/* Reset/increment for the next run. */
it->current_x = line_start_x;
+ it->wrap_prefix_width = 0;
line_start_x = 0;
it->hpos = 0;
it->line_number_produced_p = false;
@@ -10783,6 +10955,7 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int
to_x, int to_y, int to_vpos
{
it->continuation_lines_width += it->current_x;
it->current_x = it->hpos = it->max_ascent = it->max_descent = 0;
+ it->wrap_prefix_width = 0;
it->current_y += it->max_ascent + it->max_descent;
++it->vpos;
last_height = it->max_ascent + it->max_descent;
@@ -10842,6 +11015,7 @@ move_it_vertically_backward (struct it *it, int dy)
reseat_1 (it, it->current.pos, true);
/* We are now surely at a line start. */
+ it->wrap_prefix_width = 0;
it->current_x = it->hpos = 0; /* FIXME: this is incorrect when bidi
reordering is in effect. */
it->continuation_lines_width = 0;
@@ -11120,7 +11294,7 @@ move_it_by_lines (struct it *it, ptrdiff_t dvpos)
dvpos--;
}
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
/* Above call may have moved too far if continuation lines
are involved. Scan forward and see if it did. */
@@ -11129,7 +11303,7 @@ move_it_by_lines (struct it *it, ptrdiff_t dvpos)
move_it_to (&it2, start_charpos, -1, -1, -1, MOVE_TO_POS);
it->vpos -= it2.vpos;
it->current_y -= it2.current_y;
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
/* If we moved too far back, move IT some lines forward. */
if (it2.vpos > -dvpos)
@@ -11408,7 +11582,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object
from, Lisp_Object to,
IT.current_x will be incorrectly set to zero at some arbitrary
non-zero X coordinate. */
move_it_by_lines (&it, 0);
- it.current_x = it.hpos = 0;
+ it.current_x = it.hpos = it.wrap_prefix_width = 0;
if (IT_CHARPOS (it) != start)
{
void *it1data = NULL;
@@ -11461,7 +11635,7 @@ window_text_pixel_size (Lisp_Object window, Lisp_Object
from, Lisp_Object to,
/* If FROM is on a newline, pretend that we start at the beginning
of the next line, because the newline takes no place on display. */
if (FETCH_BYTE (start) == '\n')
- it.current_x = 0;
+ it.current_x = 0, it.wrap_prefix_width = 0;
if (!NILP (x_limit))
{
it.last_visible_x = max_x;
@@ -14373,7 +14547,7 @@ display_tab_bar_line (struct it *it, int height)
row->truncated_on_left_p = false;
row->truncated_on_right_p = false;
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
it->current_y += row->height;
++it->vpos;
++it->glyph_row;
@@ -15397,7 +15571,7 @@ display_tool_bar_line (struct it *it, int height)
row->truncated_on_left_p = false;
row->truncated_on_right_p = false;
- it->current_x = it->hpos = 0;
+ it->current_x = it->hpos = it->wrap_prefix_width = 0;
it->current_y += row->height;
++it->vpos;
++it->glyph_row;
@@ -17097,6 +17271,7 @@ redisplay_internal (void)
NULL, DEFAULT_FACE_ID);
it.current_x = this_line_start_x;
it.current_y = this_line_y;
+ it.wrap_prefix_width = 0;
it.vpos = this_line_vpos;
if (current_buffer->long_line_optimizations_p
@@ -18682,6 +18857,14 @@ enum
`scroll-conservatively' and the Emacs manual. */
#define SCROLL_LIMIT 100
+/* The freshness of the w->base_line_number cache is only ensured at every
+ redisplay cycle, so the cache can be used only if there's been
+ no relevant changes to the buffer since the last redisplay. */
+#define BASE_LINE_NUMBER_VALID_P(w) \
+ (eassert (current_buffer == XBUFFER ((w)->contents)), \
+ !current_buffer->clip_changed \
+ && BEG_UNCHANGED >= (w)->base_line_pos)
+
static int
try_scrolling (Lisp_Object window, bool just_this_one_p,
intmax_t arg_scroll_conservatively, intmax_t scroll_step,
@@ -18982,9 +19165,10 @@ try_scrolling (Lisp_Object window, bool
just_this_one_p,
else
{
/* Maybe forget recorded base line for line number display. */
- if (!just_this_one_p
- || current_buffer->clip_changed
- || BEG_UNCHANGED < CHARPOS (startp))
+ /* FIXME: Why do we need this? `try_scrolling` can only be called from
+ `redisplay_window` which should have flushed this cache already when
+ eeded. */
+ if (!BASE_LINE_NUMBER_VALID_P (w))
w->base_line_number = 0;
/* If cursor ends up on a partially visible line,
@@ -19754,9 +19938,6 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
/* Record it now because it's overwritten. */
bool current_matrix_up_to_date_p = false;
bool used_current_matrix_p = false;
- /* This is less strict than current_matrix_up_to_date_p.
- It indicates that the buffer contents and narrowing are unchanged. */
- bool buffer_unchanged_p = false;
bool temp_scroll_step = false;
specpdl_ref count = SPECPDL_INDEX ();
int rc;
@@ -19862,11 +20043,6 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
specbind (Qinhibit_point_motion_hooks, Qt);
- buffer_unchanged_p
- = (w->window_end_valid
- && !current_buffer->clip_changed
- && !window_outdated (w));
-
/* When windows_or_buffers_changed is non-zero, we can't rely
on the window end being valid, so set it to zero there. */
if (windows_or_buffers_changed)
@@ -20006,6 +20182,10 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
}
}
+ if (!BASE_LINE_NUMBER_VALID_P (w))
+ /* Forget any recorded base line for line number display. */
+ w->base_line_number = 0;
+
force_start:
/* Handle case where place to start displaying has been specified,
@@ -20026,10 +20206,6 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
w->preserve_vscroll_p = false;
w->window_end_valid = false;
- /* Forget any recorded base line for line number display. */
- if (!buffer_unchanged_p)
- w->base_line_number = 0;
-
/* Redisplay the mode line. Select the buffer properly for that.
Also, run the hook window-scroll-functions
because we have scrolled. */
@@ -20358,12 +20534,6 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
if (w->cursor.vpos >= 0)
{
- if (!just_this_one_p
- || current_buffer->clip_changed
- || BEG_UNCHANGED < CHARPOS (startp))
- /* Forget any recorded base line for line number display. */
- w->base_line_number = 0;
-
if (!cursor_row_fully_visible_p (w, true, false, false))
{
clear_glyph_matrix (w->desired_matrix);
@@ -20434,10 +20604,6 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
debug_method_add (w, "recenter");
#endif
- /* Forget any previously recorded base line for line number display. */
- if (!buffer_unchanged_p)
- w->base_line_number = 0;
-
/* Determine the window start relative to point. */
init_iterator (&it, w, PT, PT_BYTE, NULL, DEFAULT_FACE_ID);
it.current_y = it.last_visible_y;
@@ -20543,7 +20709,7 @@ redisplay_window (Lisp_Object window, bool
just_this_one_p)
it.current_y = 0;
}
- it.current_x = it.hpos = 0;
+ it.current_x = it.wrap_prefix_width = it.hpos = 0;
/* Set the window start position here explicitly, to avoid an
infinite loop in case the functions in window-scroll-functions
@@ -22511,7 +22677,7 @@ try_window_id (struct window *w)
/* We may start in a continuation line. If so, we have to
get the right continuation_lines_width and current_x. */
it.continuation_lines_width = last_row->continuation_lines_width;
- it.hpos = it.current_x = 0;
+ it.hpos = it.current_x = it.wrap_prefix_width = 0;
/* Display the rest of the lines at the window end. */
it.glyph_row = MATRIX_ROW (desired_matrix, it.vpos);
@@ -23116,6 +23282,7 @@ insert_left_trunc_glyphs (struct it *it)
/* Get the truncation glyphs. */
truncate_it = *it;
truncate_it.current_x = 0;
+ truncate_it.wrap_prefix_width = 0;
truncate_it.face_id = DEFAULT_FACE_ID;
truncate_it.glyph_row = &scratch_glyph_row;
truncate_it.area = TEXT_AREA;
@@ -23878,6 +24045,10 @@ extend_face_to_end_of_line (struct it *it)
for (it->current_x = 0; g < e; g++)
it->current_x += g->pixel_width;
+ if (it->continuation_lines_width
+ && it->string_from_prefix_prop_p)
+ it->wrap_prefix_width = it->current_x;
+
it->area = LEFT_MARGIN_AREA;
it->face_id = default_face->id;
while (it->glyph_row->used[LEFT_MARGIN_AREA]
@@ -24599,6 +24770,13 @@ maybe_produce_line_number (struct it *it)
if (!last_line)
{
/* If possible, reuse data cached by line-number-mode. */
+ /* NOTE: We use `base_line_number` without checking
+ BASE_LINE_NUMBER_VALID_P because we assume that `redisplay_window`
+ has already flushed this cache for us when needed.
+ NOTE2: Checking BASE_LINE_NUMBER_VALID_P here would be
+ overly pessimistic because it might say that the cache
+ was invalid before entering `redisplay_window` yet the
+ value has just been refreshed. */
if (it->w->base_line_number > 0
&& it->w->base_line_pos > 0
&& it->w->base_line_pos <= IT_CHARPOS (*it)
@@ -24878,7 +25056,7 @@ should_produce_line_number (struct it *it)
because get-char-property always returns nil for ZV, except if
the property is in 'default-text-properties'. */
if (NILP (val) && IT_CHARPOS (*it) >= ZV)
- val = disable_line_numbers_overlay_at_eob ();
+ return !disable_line_numbers_overlay_at_eob ();
return NILP (val) ? true : false;
}
@@ -24943,6 +25121,7 @@ display_line (struct it *it, int cursor_vpos)
int first_visible_x = it->first_visible_x;
int last_visible_x = it->last_visible_x;
int x_incr = 0;
+ int this_line_subject_to_line_prefix = 0;
/* We always start displaying at hpos zero even if hscrolled. */
eassert (it->hpos == 0 && it->current_x == 0);
@@ -25019,7 +25198,10 @@ display_line (struct it *it, int cursor_vpos)
if (it->current_x < it->first_visible_x
&& (move_result == MOVE_NEWLINE_OR_CR
|| move_result == MOVE_POS_MATCH_OR_ZV))
- it->current_x = it->first_visible_x;
+ {
+ it->current_x = it->first_visible_x;
+ it->wrap_prefix_width = 0;
+ }
/* In case move_it_in_display_line_to above "produced" the line
number. */
@@ -25048,6 +25230,7 @@ display_line (struct it *it, int cursor_vpos)
/* We only do this when not calling move_it_in_display_line_to
above, because that function calls itself handle_line_prefix. */
handle_line_prefix (it);
+ this_line_subject_to_line_prefix = it->string_from_prefix_prop_p;
}
else
{
@@ -25214,12 +25397,15 @@ display_line (struct it *it, int cursor_vpos)
process the prefix now. */
if (it->area == TEXT_AREA && pending_handle_line_prefix)
{
- /* Line numbers should precede the line-prefix or wrap-prefix. */
+ /* Line numbers should precede the line-prefix or
+ wrap-prefix. */
if (line_number_needed)
maybe_produce_line_number (it);
pending_handle_line_prefix = false;
handle_line_prefix (it);
+ this_line_subject_to_line_prefix
+ = it->string_from_prefix_prop_p;
}
continue;
}
@@ -25240,7 +25426,16 @@ display_line (struct it *it, int cursor_vpos)
if (/* Not a newline. */
nglyphs > 0
/* Glyphs produced fit entirely in the line. */
- && it->current_x < it->last_visible_x)
+ && (it->current_x < it->last_visible_x
+ /* Or a line or wrap prefix is in effect, and not
+ truncating the glyph produced immediately after it
+ would cause an infinite cycle. */
+ || (it->line_wrap != TRUNCATE
+ /* This code is not valid if multiple glyphs were
+ produced, as some of these glyphs might remain
+ within this line. */
+ && nglyphs == 1
+ && this_line_subject_to_line_prefix)))
{
it->hpos += nglyphs;
row->ascent = max (row->ascent, it->max_ascent);
@@ -25291,7 +25486,20 @@ display_line (struct it *it, int cursor_vpos)
&& FRAME_WINDOW_P (it->f)
&& (row->reversed_p
? WINDOW_LEFT_FRINGE_WIDTH (it->w)
- : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))
+ : WINDOW_RIGHT_FRINGE_WIDTH (it->w))))
+ /* There is no line prefix, next to which the
+ iterator _must_ produce a minimum of one actual
+ glyph. */
+ && (!this_line_subject_to_line_prefix
+ /* Or this is the second glyph to be produced
+ beyond the confines of the line. */
+ || (i != 0
+ && (x > it->last_visible_x
+ || (x == it->last_visible_x
+ && FRAME_WINDOW_P (it->f)
+ && (row->reversed_p
+ ? WINDOW_LEFT_FRINGE_WIDTH (it->w)
+ : WINDOW_RIGHT_FRINGE_WIDTH (it->w)))))))
{
/* End of a continued line. */
@@ -25588,24 +25796,23 @@ display_line (struct it *it, int cursor_vpos)
break;
}
- /* Detect overly-wide wrap-prefixes made of (space ...) display
- properties. When such a wrap prefix reaches past the right
- margin of the window, we need to avoid the call to
- set_iterator_to_next below, so that it->line_wrap is left at
- its TRUNCATE value wisely set by handle_line_prefix.
- Otherwise, set_iterator_to_next will pop the iterator stack,
- restore it->line_wrap, and redisplay might infloop. */
- bool overwide_wrap_prefix =
- CONSP (it->object) && EQ (XCAR (it->object), Qspace)
- && it->sp > 0 && it->method == GET_FROM_STRETCH
- && it->current_x >= it->last_visible_x
- && it->continuation_lines_width > 0
- && it->line_wrap == TRUNCATE && it->stack[0].line_wrap != TRUNCATE;
-
/* Proceed with next display element. Note that this skips
over lines invisible because of selective display. */
- if (!overwide_wrap_prefix)
- set_iterator_to_next (it, true);
+ set_iterator_to_next (it, true);
+
+ /* If IT has just finished producing glyphs for the wrap prefix
+ and is proceeding to the next method, there might not be
+ sufficient space remaining in this line to accommodate its
+ glyphs, and one real glyph must be produced to prevent an
+ infinite loop. Next, clear this flag if such a glyph has
+ already been produced. */
+
+ if (this_line_subject_to_line_prefix == 1
+ && !it->string_from_prefix_prop_p)
+ this_line_subject_to_line_prefix = 2;
+ else if (this_line_subject_to_line_prefix == 2
+ && !it->string_from_prefix_prop_p)
+ this_line_subject_to_line_prefix = 0;
/* If we truncate lines, we are done when the last displayed
glyphs reach past the right margin of the window. */
@@ -25851,7 +26058,7 @@ display_line (struct it *it, int cursor_vpos)
HPOS) = (0 0). Vertical positions are incremented. As a
convenience for the caller, IT->glyph_row is set to the next
row to be used. */
- it->current_x = it->hpos = 0;
+ it->wrap_prefix_width = it->current_x = it->hpos = 0;
it->current_y += row->height;
/* Restore the first and last visible X if we adjusted them for
current-line hscrolling. */
@@ -26330,7 +26537,7 @@ Value is the new character position of point. */)
{
struct text_pos pt;
struct it it;
- int pt_x, target_x, pixel_width, pt_vpos;
+ int pt_x, pt_wrap_prefix_x, target_x, pixel_width, pt_vpos;
bool at_eol_p;
bool overshoot_expected = false;
bool target_is_eol_p = false;
@@ -26362,6 +26569,7 @@ Value is the new character position of point. */)
reseat:
reseat_at_previous_visible_line_start (&it);
it.current_x = it.hpos = it.current_y = it.vpos = 0;
+ it.wrap_prefix_width = 0;
if (IT_CHARPOS (it) != PT)
{
move_it_to (&it, overshoot_expected ? PT - 1 : PT,
@@ -26380,6 +26588,7 @@ Value is the new character position of point. */)
move_it_in_display_line (&it, PT, -1, MOVE_TO_POS);
}
pt_x = it.current_x;
+ pt_wrap_prefix_x = it.wrap_prefix_width;
pt_vpos = it.vpos;
if (dir > 0 || overshoot_expected)
{
@@ -26394,10 +26603,11 @@ Value is the new character position of point. */)
it.glyph_row = NULL;
PRODUCE_GLYPHS (&it); /* compute it.pixel_width */
it.glyph_row = row;
- /* PRODUCE_GLYPHS advances it.current_x, so we must restore
- it, lest it will become out of sync with it's buffer
+ /* PRODUCE_GLYPHS advances it.current_x, so it must be
+ restored, lest it become out of sync with its buffer
position. */
it.current_x = pt_x;
+ it.wrap_prefix_width = pt_wrap_prefix_x;
}
else
at_eol_p = ITERATOR_AT_END_OF_LINE_P (&it);
@@ -26442,6 +26652,7 @@ Value is the new character position of point. */)
it.last_visible_x = DISP_INFINITY;
reseat_at_previous_visible_line_start (&it);
it.current_x = it.current_y = it.hpos = 0;
+ it.wrap_prefix_width = 0;
if (pt_vpos != 0)
move_it_by_lines (&it, pt_vpos);
}
@@ -27958,6 +28169,11 @@ are the selected window and the WINDOW's buffer). */)
init_iterator (&it, w, -1, -1, NULL, face_id);
+ /* Make sure `base_line_number` is fresh in case we encounter a `%l`. */
+ if (current_buffer == XBUFFER ((w)->contents)
+ && !BASE_LINE_NUMBER_VALID_P (w))
+ w->base_line_number = 0;
+
if (no_props)
{
mode_line_target = MODE_LINE_NOPROP;
@@ -28410,30 +28626,29 @@ decode_mode_spec (struct window *w, register int c,
int field_width,
when the buffer's restriction was changed, but the window
wasn't yet redisplayed after that. If that happens, we
need to determine a new base line. */
- if (!(BUF_BEGV_BYTE (b) <= startpos_byte
+ if (current_buffer != XBUFFER (w->contents)
+ || !(BUF_BEGV_BYTE (b) <= startpos_byte
&& startpos_byte <= BUF_ZV_BYTE (b)))
{
startpos = BUF_BEGV (b);
startpos_byte = BUF_BEGV_BYTE (b);
- w->base_line_pos = 0;
- w->base_line_number = 0;
}
/* If we decided that this buffer isn't suitable for line numbers,
- don't forget that too fast. */
+ don't forget that too fast.
+ FIXME: What if `current_buffer != w->contents`? */
if (w->base_line_pos == -1)
goto no_value;
/* If the buffer is very big, don't waste time. */
if (FIXNUMP (Vline_number_display_limit)
&& BUF_ZV (b) - BUF_BEGV (b) > XFIXNUM (Vline_number_display_limit))
- {
- w->base_line_pos = 0;
- w->base_line_number = 0;
- goto no_value;
- }
+ goto no_value;
- if (w->base_line_number > 0
+ /* Callers of `display_mode_element` are in charge of flushing
+ any stale `base_line_number` cache. */
+ if (current_buffer == XBUFFER ((w)->contents)
+ && w->base_line_number > 0
&& w->base_line_pos > 0
&& w->base_line_pos <= startpos)
{
@@ -28459,7 +28674,9 @@ decode_mode_spec (struct window *w, register int c, int
field_width,
or too far away, or if we did not have one.
"Too close" means it's plausible a scroll-down would
go back past it. */
- if (startpos == BUF_BEGV (b))
+ if (current_buffer != XBUFFER (w->contents))
+ ; /* The base line is for another buffer, don't touch it! */
+ else if (startpos == BUF_BEGV (b))
{
w->base_line_number = topline;
w->base_line_pos = BUF_BEGV (b);
@@ -28496,6 +28713,12 @@ decode_mode_spec (struct window *w, register int c,
int field_width,
goto no_value;
}
+ /* NOTE: if `clip_changed` is set or if `BEG_UNCHANGED` is
+ before `position`, this new cached value may get flushed
+ soon needlessly, because we can't reset `BEG_UNCHANGED` or
+ `clip_changed` from here (since they reflect the changes
+ since the last redisplay so they can only be reset from
+ `mark_window_display_accurate_1`). :-( */
w->base_line_number = topline - nlines;
w->base_line_pos = BYTE_TO_CHAR (position);
}
@@ -32589,7 +32812,19 @@ gui_produce_glyphs (struct it *it)
if (font->space_width > 0)
{
int tab_width = it->tab_width * font->space_width;
- int x = it->current_x + it->continuation_lines_width;
+ /* wrap-prefix strings are prepended to continuation
+ lines, so the width of tab characters inside should
+ be computed from the start of this screen line rather
+ than as a product of the total width of the physical
+ line being wrapped. */
+ int x = it->current_x + (it->string_from_prefix_prop_p
+ /* Subtract the width of the
+ prefix from it->current_x if
+ it exists. */
+ ? 0 : (it->continuation_lines_width
+ ? (it->continuation_lines_width
+ - it->wrap_prefix_width)
+ : 0));
int x0 = x;
/* Adjust for line numbers, if needed. */
if (!NILP (Vdisplay_line_numbers) && it->line_number_produced_p)
@@ -33060,7 +33295,13 @@ gui_produce_glyphs (struct it *it)
because this isn't true for images with `:ascent 100'. */
eassert (it->ascent >= 0 && it->descent >= 0);
if (it->area == TEXT_AREA)
- it->current_x += it->pixel_width;
+ {
+ it->current_x += it->pixel_width;
+
+ if (it->continuation_lines_width
+ && it->string_from_prefix_prop_p)
+ it->wrap_prefix_width = it->current_x;
+ }
if (extra_line_spacing > 0)
{
@@ -36219,7 +36460,7 @@ expose_area (struct window *w, struct glyph_row *row,
const Emacs_Rectangle *r,
/* Use a signed int intermediate value to avoid catastrophic
failures due to comparison between signed and unsigned, when
x is negative (can happen for wide images that are hscrolled). */
- int r_end = r->x + r->width;
+ int r_end = r->x + (int) r->width;
while (last < end && x < r_end)
{
x += last->pixel_width;
@@ -36518,7 +36759,7 @@ expose_window (struct window *w, const Emacs_Rectangle
*fr)
/* Use a signed int intermediate value to avoid catastrophic
failures due to comparison between signed and unsigned, when
y0 or y1 is negative (can happen for tall images). */
- int r_bottom = r.y + r.height;
+ int r_bottom = r.y + (int) r.height;
/* We must temporarily switch to the window's buffer, in case
the fringe face has been remapped in that buffer's
@@ -36565,7 +36806,7 @@ expose_window (struct window *w, const Emacs_Rectangle
*fr)
/* We must redraw a row overlapping the exposed area. */
if (y0 < r.y
? y0 + row->phys_height > r.y
- : y0 + row->ascent - row->phys_ascent < r.y +r.height)
+ : y0 + row->ascent - row->phys_ascent < r.y + (int) r.height)
{
if (first_overlapping_row == NULL)
first_overlapping_row = row;
@@ -36744,7 +36985,7 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1,
const Emacs_Rectangle *r2,
const Emacs_Rectangle *upper, *lower;
bool intersection_p = false;
- /* Rearrange so that R1 is the left-most rectangle. */
+ /* Rearrange so that left is the left-most rectangle. */
if (r1->x < r2->x)
left = r1, right = r2;
else
@@ -36752,13 +36993,14 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1,
const Emacs_Rectangle *r2,
/* X0 of the intersection is right.x0, if this is inside R1,
otherwise there is no intersection. */
- if (right->x <= left->x + left->width)
+ if (right->x <= left->x + (int) left->width)
{
result->x = right->x;
/* The right end of the intersection is the minimum of
the right ends of left and right. */
- result->width = (min (left->x + left->width, right->x + right->width)
+ result->width = (min (left->x + (int) left->width,
+ right->x + (int) right->width)
- result->x);
/* Same game for Y. */
@@ -36769,14 +37011,14 @@ gui_intersect_rectangles (const Emacs_Rectangle *r1,
const Emacs_Rectangle *r2,
/* The upper end of the intersection is lower.y0, if this is inside
of upper. Otherwise, there is no intersection. */
- if (lower->y <= upper->y + upper->height)
+ if (lower->y <= upper->y + (int) upper->height)
{
result->y = lower->y;
/* The lower end of the intersection is the minimum of the lower
ends of upper and lower. */
- result->height = (min (lower->y + lower->height,
- upper->y + upper->height)
+ result->height = (min (lower->y + (int) lower->height,
+ upper->y + (int) upper->height)
- result->y);
intersection_p = true;
}
diff --git a/src/xfaces.c b/src/xfaces.c
index b9a78328661..a558e7328c0 100644
--- a/src/xfaces.c
+++ b/src/xfaces.c
@@ -2245,20 +2245,20 @@ merge_face_heights (Lisp_Object from, Lisp_Object to,
Lisp_Object invalid)
/* Merge two Lisp face attribute vectors on frame F, FROM and TO, and
store the resulting attributes in TO, which must be already be
- completely specified and contain only absolute attributes.
- Every specified attribute of FROM overrides the corresponding
- attribute of TO; relative attributes in FROM are merged with the
- absolute value in TO and replace it. NAMED_MERGE_POINTS is used
- internally to detect loops in face inheritance/remapping; it should
- be 0 when called from other places. If window W is non-NULL, use W
- to interpret face specifications. */
+ completely specified and contain only absolute attributes. Every
+ specified attribute of FROM overrides the corresponding attribute of
+ TO; merge relative attributes in FROM with the absolute value in TO,
+ which attributes also replace it. Use NAMED_MERGE_POINTS internally
+ to detect loops in face inheritance/remapping; it should be 0 when
+ called from other places. If window W is non-NULL, use W to
+ interpret face specifications. */
static void
merge_face_vectors (struct window *w,
struct frame *f, const Lisp_Object *from, Lisp_Object *to,
struct named_merge_point *named_merge_points)
{
int i;
- Lisp_Object font = Qnil;
+ Lisp_Object font = Qnil, tospec, adstyle;
/* If FROM inherits from some other faces, merge their attributes into
TO before merging FROM's direct attributes. Note that an :inherit
@@ -2318,6 +2318,25 @@ merge_face_vectors (struct window *w,
to[LFACE_SLANT_INDEX] = FONT_SLANT_FOR_FACE (font);
if (! NILP (AREF (font, FONT_WIDTH_INDEX)))
to[LFACE_SWIDTH_INDEX] = FONT_WIDTH_FOR_FACE (font);
+
+ if (!NILP (AREF (font, FONT_ADSTYLE_INDEX)))
+ {
+ /* If an adstyle is specified in FROM's font spec, create a
+ font spec for TO if none exists, and transfer the adstyle
+ there. */
+
+ tospec = to[LFACE_FONT_INDEX];
+ adstyle = AREF (font, FONT_ADSTYLE_INDEX);
+
+ if (!NILP (tospec))
+ tospec = copy_font_spec (tospec);
+ else
+ tospec = Ffont_spec (0, NULL);
+
+ to[LFACE_FONT_INDEX] = tospec;
+ ASET (tospec, FONT_ADSTYLE_INDEX, adstyle);
+ }
+
ASET (font, FONT_SIZE_INDEX, Qnil);
}
diff --git a/test/Makefile.in b/test/Makefile.in
index 720f5c7ff8c..3cbdbec4414 100644
--- a/test/Makefile.in
+++ b/test/Makefile.in
@@ -92,6 +92,10 @@ export TEST_LOAD_EL ?= \
# Additional settings for ert.
ert_opts =
+# Supply a path to local tree-sitter installations, as we run tests
+# without a valid HOME.
+ert_opts += --eval "(setq treesit-extra-load-path
'(\"$(HOME)/.emacs.d/tree-sitter\"))"
+
# Maximum length of lines in ert backtraces; nil for no limit.
# (if empty, use the default ert-batch-backtrace-right-margin).
TEST_BACKTRACE_LINE_LENGTH =
diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba
index 8e583fade9f..d79072b06b5 100644
--- a/test/infra/Dockerfile.emba
+++ b/test/infra/Dockerfile.emba
@@ -126,7 +126,7 @@ RUN src/emacs -Q --batch \
(java "https://github.com/tree-sitter/tree-sitter-java";) \
(javascript "https://github.com/tree-sitter/tree-sitter-javascript";) \
(json "https://github.com/tree-sitter/tree-sitter-json";) \
- (lua "https://github.com/MunifTanjim/tree-sitter-lua";) \
+ (lua "https://github.com/tree-sitter-grammars/tree-sitter-lua";) \
(python "https://github.com/tree-sitter/tree-sitter-python";) \
(ruby "https://github.com/tree-sitter/tree-sitter-ruby";) \
(tsx "https://github.com/tree-sitter/tree-sitter-typescript"; "master"
"tsx/src") \
diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el
index bfdfac8be1b..cdd1a7832d3 100644
--- a/test/lisp/abbrev-tests.el
+++ b/test/lisp/abbrev-tests.el
@@ -57,12 +57,10 @@
(ert-deftest abbrev-make-abbrev-table-test ()
;; Table without properties:
(let ((table (make-abbrev-table)))
- (should (abbrev-table-p table))
- (should (= (length table) obarray-default-size)))
+ (should (abbrev-table-p table)))
;; Table with one property 'foo with value 'bar:
(let ((table (make-abbrev-table '(foo bar))))
(should (abbrev-table-p table))
- (should (= (length table) obarray-default-size))
(should (eq (abbrev-table-get table 'foo) 'bar))))
(ert-deftest abbrev--table-symbols-test ()
diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el
index 0a3c1cce590..c091a7dd060 100644
--- a/test/lisp/auth-source-tests.el
+++ b/test/lisp/auth-source-tests.el
@@ -33,8 +33,8 @@
(require 'secrets)
(defun auth-source-ensure-ignored-backend (source)
- (auth-source-validate-backend source '((:source . "")
- (:type . ignore))))
+ (auth-source-validate-backend source '((source . "")
+ (type . ignore))))
(defun auth-source-validate-backend (source validation-alist)
(let ((backend (auth-source-backend-parse source)))
@@ -44,84 +44,101 @@
(ert-deftest auth-source-backend-parse-macos-keychain ()
(auth-source-validate-backend '(:source (:macos-keychain-generic foobar))
- '((:source . "foobar")
- (:type . macos-keychain-generic)
- (:search-function .
auth-source-macos-keychain-search)
- (:create-function .
auth-source-macos-keychain-create))))
+ '((source . "foobar")
+ (type . macos-keychain-generic)
+ (search-function .
auth-source-macos-keychain-search)
+ (create-function .
auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-generic-string ()
(auth-source-validate-backend "macos-keychain-generic:foobar"
- '((:source . "foobar")
- (:type . macos-keychain-generic)
- (:search-function .
auth-source-macos-keychain-search)
- (:create-function .
auth-source-macos-keychain-create))))
+ '((source . "foobar")
+ (type . macos-keychain-generic)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-internet-string ()
(auth-source-validate-backend "macos-keychain-internet:foobar"
- '((:source . "foobar")
- (:type . macos-keychain-internet)
- (:search-function .
auth-source-macos-keychain-search)
- (:create-function .
auth-source-macos-keychain-create))))
+ '((source . "foobar")
+ (type . macos-keychain-internet)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-internet-symbol ()
(auth-source-validate-backend 'macos-keychain-internet
- '((:source . "default")
- (:type . macos-keychain-internet)
- (:search-function .
auth-source-macos-keychain-search)
- (:create-function .
auth-source-macos-keychain-create))))
+ '((source . "default")
+ (type . macos-keychain-internet)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-generic-symbol ()
(auth-source-validate-backend 'macos-keychain-generic
- '((:source . "default")
- (:type . macos-keychain-generic)
- (:search-function .
auth-source-macos-keychain-search)
- (:create-function .
auth-source-macos-keychain-create))))
+ '((source . "default")
+ (type . macos-keychain-generic)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-macos-keychain-internet-default-string
()
(auth-source-validate-backend 'macos-keychain-internet
- '((:source . "default")
- (:type . macos-keychain-internet)
- (:search-function .
auth-source-macos-keychain-search)
- (:create-function .
auth-source-macos-keychain-create))))
+ '((source . "default")
+ (type . macos-keychain-internet)
+ (search-function
+ . auth-source-macos-keychain-search)
+ (create-function
+ . auth-source-macos-keychain-create))))
(ert-deftest auth-source-backend-parse-plstore ()
(auth-source-validate-backend '(:source "foo.plist")
- '((:source . "foo.plist")
- (:type . plstore)
- (:search-function .
auth-source-plstore-search)
- (:create-function .
auth-source-plstore-create))))
+ '((source . "foo.plist")
+ (type . plstore)
+ (search-function .
auth-source-plstore-search)
+ (create-function
+ . auth-source-plstore-create))))
(ert-deftest auth-source-backend-parse-netrc ()
(auth-source-validate-backend '(:source "foo")
- '((:source . "foo")
- (:type . netrc)
- (:search-function . auth-source-netrc-search)
- (:create-function .
auth-source-netrc-create))))
+ '((source . "foo")
+ (type . netrc)
+ (search-function . auth-source-netrc-search)
+ (create-function
+ . auth-source-netrc-create))))
(ert-deftest auth-source-backend-parse-netrc-string ()
(auth-source-validate-backend "foo"
- '((:source . "foo")
- (:type . netrc)
- (:search-function . auth-source-netrc-search)
- (:create-function .
auth-source-netrc-create))))
+ '((source . "foo")
+ (type . netrc)
+ (search-function . auth-source-netrc-search)
+ (create-function
+ . auth-source-netrc-create))))
(ert-deftest auth-source-backend-parse-secrets ()
(provide 'secrets) ; simulates the presence of the `secrets' package
(let ((secrets-enabled t))
(auth-source-validate-backend '(:source (:secrets "foo"))
- '((:source . "foo")
- (:type . secrets)
- (:search-function .
auth-source-secrets-search)
- (:create-function .
auth-source-secrets-create)))))
+ '((source . "foo")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create)))))
(ert-deftest auth-source-backend-parse-secrets-strings ()
(provide 'secrets) ; simulates the presence of the `secrets' package
(let ((secrets-enabled t))
(auth-source-validate-backend "secrets:foo"
- '((:source . "foo")
- (:type . secrets)
- (:search-function .
auth-source-secrets-search)
- (:create-function .
auth-source-secrets-create)))))
+ '((source . "foo")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create)))))
(ert-deftest auth-source-backend-parse-secrets-alias ()
(provide 'secrets) ; simulates the presence of the `secrets' package
@@ -129,10 +146,12 @@
;; Redefine `secrets-get-alias' to map 'foo to "foo"
(cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo")))
(auth-source-validate-backend '(:source (:secrets foo))
- '((:source . "foo")
- (:type . secrets)
- (:search-function .
auth-source-secrets-search)
- (:create-function .
auth-source-secrets-create))))))
+ '((source . "foo")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create))))))
(ert-deftest auth-source-backend-parse-secrets-symbol ()
(provide 'secrets) ; simulates the presence of the `secrets' package
@@ -140,10 +159,12 @@
;; Redefine `secrets-get-alias' to map 'default to "foo"
(cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) "foo")))
(auth-source-validate-backend 'default
- '((:source . "foo")
- (:type . secrets)
- (:search-function .
auth-source-secrets-search)
- (:create-function .
auth-source-secrets-create))))))
+ '((source . "foo")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create))))))
(ert-deftest auth-source-backend-parse-secrets-no-alias ()
(provide 'secrets) ; simulates the presence of the `secrets' package
@@ -152,10 +173,12 @@
;; "Login" is used by default
(cl-letf (((symbol-function 'secrets-get-alias) (lambda (_) nil)))
(auth-source-validate-backend '(:source (:secrets foo))
- '((:source . "Login")
- (:type . secrets)
- (:search-function .
auth-source-secrets-search)
- (:create-function .
auth-source-secrets-create))))))
+ '((source . "Login")
+ (type . secrets)
+ (search-function
+ . auth-source-secrets-search)
+ (create-function
+ . auth-source-secrets-create))))))
(ert-deftest auth-source-backend-parse-invalid-or-nil-source ()
(provide 'secrets) ; simulates the presence of the `secrets' package
diff --git a/test/lisp/completion-preview-tests.el
b/test/lisp/completion-preview-tests.el
index 190764e9125..5b2c28bd3dd 100644
--- a/test/lisp/completion-preview-tests.el
+++ b/test/lisp/completion-preview-tests.el
@@ -181,4 +181,19 @@ instead."
(completion-preview--post-command))
(completion-preview-tests--check-preview "barbaz" 'exact)))
+(ert-deftest completion-preview-mid-symbol-cycle ()
+ "Test cycling the completion preview with point at the middle of a symbol."
+ (with-temp-buffer
+ (setq-local completion-at-point-functions
+ (list
+ (completion-preview-tests--capf
+ '("foobar" "foobaz"))))
+ (insert "fooba")
+ (forward-char -2)
+ (let ((this-command 'self-insert-command))
+ (completion-preview--post-command))
+ (completion-preview-tests--check-preview "r")
+ (completion-preview-next-candidate 1)
+ (completion-preview-tests--check-preview "z")))
+
;;; completion-preview-tests.el ends here
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el
b/test/lisp/emacs-lisp/bytecomp-tests.el
index dcb72e4105a..8ccac492141 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -848,6 +848,22 @@ byte-compiled. Run with dynamic binding."
(should (equal (bytecomp-tests--eval-interpreted form)
(bytecomp-tests--eval-compiled form)))))))
+(ert-deftest bytecomp--fun-value-as-head ()
+ ;; Check that (FUN-VALUE ...) is a valid call, for compatibility (bug#68931).
+ ;; (There is also a warning but this test does not check that.)
+ (dolist (lb '(nil t))
+ (ert-info ((prin1-to-string lb) :prefix "lexical-binding: ")
+ (let* ((lexical-binding lb)
+ (s-int '(lambda (x) (1+ x)))
+ (s-comp (byte-compile s-int))
+ (v-int (lambda (x) (1+ x)))
+ (v-comp (byte-compile v-int))
+ (comp (lambda (f) (funcall (byte-compile `(lambda () (,f 3)))))))
+ (should (equal (funcall comp s-int) 4))
+ (should (equal (funcall comp s-comp) 4))
+ (should (equal (funcall comp v-int) 4))
+ (should (equal (funcall comp v-comp) 4))))))
+
(defmacro bytecomp-tests--with-fresh-warnings (&rest body)
`(let ((macroexp--warned ; oh dear
(make-hash-table :test #'equal :weakness 'key)))
diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el
b/test/lisp/emacs-lisp/cl-generic-tests.el
index 086ac399352..990fa580c54 100644
--- a/test/lisp/emacs-lisp/cl-generic-tests.el
+++ b/test/lisp/emacs-lisp/cl-generic-tests.el
@@ -319,5 +319,19 @@ Edebug symbols (Bug#42672)."
(and (eq 'error (car err))
(string-match "Stray.*declare" (cadr err)))))))
+(cl-defmethod cl-generic-tests--print-quoted-method ((function (eql '4)))
+ (+ function 1))
+
+(ert-deftest cl-generic-tests--print-quoted ()
+ (with-temp-buffer
+ (cl--generic-describe 'cl-generic-tests--print-quoted-method)
+ (goto-char (point-min))
+ ;; Bug#54628: We don't want (function (eql '4)) to turn into #'(eql '4)
+ (should-not (re-search-forward "#'" nil t))
+ (goto-char (point-min))
+ ;; But we don't want (eql '4) to turn into (eql (quote 4)) either.
+ (should (re-search-forward "(eql '4)" nil t))))
+
+
(provide 'cl-generic-tests)
;;; cl-generic-tests.el ends here
diff --git a/test/lisp/emacs-lisp/edebug-tests.el
b/test/lisp/emacs-lisp/edebug-tests.el
index 8c0f729dc39..29adbcff947 100644
--- a/test/lisp/emacs-lisp/edebug-tests.el
+++ b/test/lisp/emacs-lisp/edebug-tests.el
@@ -860,8 +860,7 @@ test and possibly others should be updated."
(let ((inhibit-read-only t))
(delete-region (point-min) (point-max))
(insert "`1"))
- (with-suppressed-warnings ((obsolete edebug-eval-defun))
- (edebug-eval-defun nil))
+ (eval-defun nil)
;; `eval-defun' outputs its message to the echo area in a rather
;; funny way, so the "1" and the " (#o1, #x1, ?\C-a)" end up placed
;; there in separate pieces (via `print' rather than via `message').
@@ -871,18 +870,21 @@ test and possibly others should be updated."
(setq edebug-initial-mode 'go)
;; In Bug#23651 Edebug would hang reading `1.
- (with-suppressed-warnings ((obsolete edebug-eval-defun))
- (edebug-eval-defun t))))
+ (eval-defun t)
+ (should (string-match-p (regexp-quote " (#o1, #x1, ?\\C-a)")
+ edebug-tests-messages))))
(ert-deftest edebug-tests-trivial-comma ()
"Edebug can read a trivial comma expression (Bug#23651)."
(edebug-tests-with-normal-env
- (read-only-mode -1)
- (delete-region (point-min) (point-max))
- (insert ",1")
- (read-only-mode)
- (with-suppressed-warnings ((obsolete edebug-eval-defun))
- (should-error (edebug-eval-defun t)))))
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) (point-max))
+ (insert ",1"))
+ ;; FIXME: This currently signals a "Source has changed" error, which is
+ ;; itself a bug (the source hasn't changed). All we're testing here
+ ;; is that the Edebug gets past the step of reading the sexp.
+ (should-error (let ((eval-expression-debug-on-error nil))
+ (eval-defun t)))))
(ert-deftest edebug-tests-circular-read-syntax ()
"Edebug can instrument code using circular read object syntax (Bug#23660)."
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
index 83fc476c911..bc226757ff2 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el
@@ -1011,24 +1011,24 @@ Subclasses to override slot attributes."))
(B (clone A :b "bb"))
(C (clone B :a "aa")))
- (should (string= "aa" (oref C :a)))
- (should (string= "bb" (oref C :b)))
+ (should (string= "aa" (oref C a)))
+ (should (string= "bb" (oref C b)))
- (should (slot-boundp A :a))
- (should-not (slot-boundp A :b))
- (should-not (slot-boundp A :c))
+ (should (slot-boundp A 'a))
+ (should-not (slot-boundp A 'b))
+ (should-not (slot-boundp A 'c))
- (should-not (slot-boundp B :a))
- (should (slot-boundp B :b))
- (should-not (slot-boundp A :c))
+ (should-not (slot-boundp B 'a))
+ (should (slot-boundp B 'b))
+ (should-not (slot-boundp A 'c))
- (should (slot-boundp C :a))
- (should-not (slot-boundp C :b))
- (should-not (slot-boundp C :c))
+ (should (slot-boundp C 'a))
+ (should-not (slot-boundp C 'b))
+ (should-not (slot-boundp C 'c))
- (should (eieio-instance-inheritor-slot-boundp C :a))
- (should (eieio-instance-inheritor-slot-boundp C :b))
- (should-not (eieio-instance-inheritor-slot-boundp C :c))))
+ (should (eieio-instance-inheritor-slot-boundp C 'a))
+ (should (eieio-instance-inheritor-slot-boundp C 'b))
+ (should-not (eieio-instance-inheritor-slot-boundp C 'c))))
;;;; Interaction with defstruct
diff --git a/test/lisp/emacs-lisp/hierarchy-tests.el
b/test/lisp/emacs-lisp/hierarchy-tests.el
index 49c812edb05..3333f4014e6 100644
--- a/test/lisp/emacs-lisp/hierarchy-tests.el
+++ b/test/lisp/emacs-lisp/hierarchy-tests.el
@@ -570,8 +570,9 @@ should fail as this function will crash."
(defun hierarchy-examples-delayed--childrenfn (hier-elem)
"Return the children of HIER-ELEM.
-Basically, feed the number, minus 1, to
`hierarchy-examples-delayed--find-number'
-and then create a list of the number plus 0.0–0.9."
+Basically, feed the number, minus 1, to
+`hierarchy-examples-delayed--find-number' and then create a list of the
+number plus 0.0–0.9."
(when (> hier-elem 1)
(let ((next (hierarchy-examples-delayed--find-number (1- hier-elem))))
diff --git a/test/lisp/emacs-lisp/macroexp-resources/vk.el
b/test/lisp/emacs-lisp/macroexp-resources/vk.el
index 460b7a8e516..5358bcaeb5c 100644
--- a/test/lisp/emacs-lisp/macroexp-resources/vk.el
+++ b/test/lisp/emacs-lisp/macroexp-resources/vk.el
@@ -25,7 +25,7 @@
(if (macroexp--dynamic-variable-p var) ''dyn ''lex))
(defvar vk-a 1)
-(defconst vk-b 2)
+(defvar vk-b 2)
(defvar vk-c)
(defun vk-f1 (x)
diff --git a/test/lisp/erc/erc-button-tests.el
b/test/lisp/erc/erc-button-tests.el
index ba6fe9fd8c1..603b3745a27 100644
--- a/test/lisp/erc/erc-button-tests.el
+++ b/test/lisp/erc/erc-button-tests.el
@@ -20,14 +20,13 @@
;;; Commentary:
;;; Code:
+(require 'erc-button)
(require 'ert-x) ; cl-lib
(eval-and-compile
(let ((load-path (cons (ert-resource-directory) load-path)))
(require 'erc-tests-common)))
-(require 'erc-button)
-
(ert-deftest erc-button-alist--url ()
(erc-tests-common-init-server-proc "sleep" "1")
(with-current-buffer (erc--open-target "#chan")
diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el
index 0f19b481f37..3c4ad04abd7 100644
--- a/test/lisp/erc/erc-fill-tests.el
+++ b/test/lisp/erc/erc-fill-tests.el
@@ -23,13 +23,13 @@
;; scenarios.
;;; Code:
+(require 'erc-fill)
+
(require 'ert-x)
(eval-and-compile
(let ((load-path (cons (ert-resource-directory) load-path)))
(require 'erc-tests-common)))
-(require 'erc-fill)
-
(defvar erc-fill-tests--buffers nil)
(defvar erc-fill-tests--current-time-value nil)
@@ -52,6 +52,7 @@
(defun erc-fill-tests--wrap-populate (test)
(let ((original-window-buffer (window-buffer (selected-window)))
+ (erc--fill-wrap-scrolltobottom-exempt-p t)
(erc-stamp--tz t)
(erc-fill-function 'erc-fill-wrap)
(pre-command-hook pre-command-hook)
diff --git a/test/lisp/erc/erc-goodies-tests.el
b/test/lisp/erc/erc-goodies-tests.el
index 170e28bda96..7013ce0c8fc 100644
--- a/test/lisp/erc/erc-goodies-tests.el
+++ b/test/lisp/erc/erc-goodies-tests.el
@@ -19,13 +19,13 @@
;;; Commentary:
;;; Code:
+(require 'erc-goodies)
+
(require 'ert-x)
(eval-and-compile
(let ((load-path (cons (ert-resource-directory) load-path)))
(require 'erc-tests-common)))
-(require 'erc-goodies)
-
(defun erc-goodies-tests--assert-face (beg end-str present &optional absent)
(setq beg (+ beg (point-min)))
(let ((end (+ beg (1- (length end-str)))))
diff --git a/test/lisp/erc/erc-networks-tests.el
b/test/lisp/erc/erc-networks-tests.el
index d8d8c6fa9cd..90b8aa99741 100644
--- a/test/lisp/erc/erc-networks-tests.el
+++ b/test/lisp/erc/erc-networks-tests.el
@@ -18,6 +18,7 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
+(require 'erc-compat)
(require 'ert-x) ; cl-lib
(eval-and-compile
@@ -1761,4 +1762,50 @@
(should (equal (erc-ports-list (nth 4 srv))
'(6697 9999))))))
+(ert-deftest erc-networks--examine-targets ()
+ (with-current-buffer (erc-tests-common-make-server-buf "foonet")
+ (erc--open-target "#chan")
+ (erc--open-target "#spam"))
+
+ (with-current-buffer (erc-tests-common-make-server-buf "barnet")
+ (with-current-buffer (erc--open-target "*query")
+ (setq erc-networks--id nil))
+ (with-current-buffer (erc--open-target "#chan")
+ (let ((calls ())
+ (snap (lambda (parameter)
+ (list parameter
+ (erc-target)
+ (erc-networks--id-symbol erc-networks--id)))))
+
+ ;; Search for "#chan" dupes among targets of all servers.
+ (should (equal
+ (erc-networks--examine-targets erc-networks--id erc--target
+ (lambda () (push (funcall snap 'ON-DUPE) calls))
+ (lambda () (push (funcall snap 'ON-COLL) calls)))
+ (list (get-buffer "#chan@foonet")
+ (get-buffer "#chan@barnet"))))
+
+ (should (equal (pop calls) '(ON-DUPE "#chan" barnet)))
+ (should (equal (pop calls) '(ON-COLL "#chan" foonet)))
+ (should-not calls)
+ (should-not (get-buffer "#chan"))
+ (should (get-buffer "#chan@barnet"))
+ (should (get-buffer "#chan@foonet"))
+
+ ;; Search for "*query" dupes among targets of all servers.
+ (should (equal (erc-networks--examine-targets erc-networks--id
+ (buffer-local-value 'erc--target
+ (get-buffer "*query"))
+ (lambda () (push (funcall snap 'ON-DUPE) calls))
+ (lambda () (push (funcall snap 'ON-COLL) calls)))
+ (list (get-buffer "*query"))))
+
+ (should (equal (pop calls) '(ON-DUPE "*query" barnet)))
+ (should-not calls)))
+
+ (goto-char (point-min))
+ (should (search-forward "Missing network session" nil t)))
+
+ (erc-tests-common-kill-buffers))
+
;;; erc-networks-tests.el ends here
diff --git a/test/lisp/erc/erc-scenarios-base-renick.el
b/test/lisp/erc/erc-scenarios-base-renick.el
index ca22728b152..e0fcb8b9366 100644
--- a/test/lisp/erc/erc-scenarios-base-renick.el
+++ b/test/lisp/erc/erc-scenarios-base-renick.el
@@ -281,12 +281,12 @@
(should-not (get-buffer "rando@barnet"))
(with-current-buffer "frenemy@foonet"
- (funcall expect 1 "now known as")
- (funcall expect 1 "doubly so"))
+ (funcall expect 10 "now known as")
+ (funcall expect 10 "doubly so"))
(with-current-buffer "frenemy@barnet"
- (funcall expect 1 "now known as")
- (funcall expect 1 "reality picture"))
+ (funcall expect 10 "now known as")
+ (funcall expect 10 "reality picture"))
(when noninteractive
(with-current-buffer "frenemy@barnet" (kill-buffer))
diff --git a/test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el
b/test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el
index bbd9c79f593..f3905974a11 100644
--- a/test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el
+++ b/test/lisp/erc/erc-scenarios-base-upstream-recon-znc.el
@@ -42,4 +42,50 @@
'znc-foonet
'znc-barnet))
+;; Here, the upstream connection is already severed when first
+;; connecting. The bouncer therefore sends query messages from an
+;; administrative bot before the first numerics burst, which results
+;; in a target buffer not being associated with an `erc-networks--id'.
+;; The problem only manifests later, when the buffer-association
+;; machinery checks the names of all target buffers and assumes a
+;; non-nil `erc-networks--id'.
+(ert-deftest erc-scenarios-upstream-recon--znc/severed ()
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "base/upstream-reconnect")
+ (erc-d-t-cleanup-sleep-secs 1)
+ (erc-server-flood-penalty 0.1)
+ (dumb-server (erc-d-run "localhost" t 'znc-severed))
+ (port (process-contact dumb-server :service))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet")
+ (with-current-buffer (erc :server "127.0.0.1"
+ :port port
+ :nick "tester"
+ :user "tester@vanilla/foonet"
+ :password "changeme"
+ :full-name "tester")
+ (erc-scenarios-common-assert-initial-buf-name nil port)
+ (erc-d-t-wait-for 6 (eq (erc-network) 'foonet))))
+
+ (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "*status"))
+ (funcall expect 10 "Connection Refused. Reconnecting...")
+ (funcall expect 10 "Connected!"))
+
+ (ert-info ("Join #chan")
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan"))
+ (funcall expect 10 "<alice> tester, welcome!")
+ (funcall expect 10 "<bob> alice: And see a fearful sight")
+ (funcall expect 10 "<eve> hola")
+ (funcall expect 10 "<Evel> hell o")
+ ;;
+ (funcall expect 10 "<alice> bob: Or to drown my clothes")))
+
+ (ert-info ("Buffer not renamed with net id")
+ (should (get-buffer "*status")))
+
+ (ert-info ("No error")
+ (with-current-buffer (messages-buffer)
+ (funcall expect -0.1 "error in process filter")))))
+
;;; erc-scenarios-base-upstream-recon-znc.el ends here
diff --git a/test/lisp/erc/erc-scenarios-misc-commands.el
b/test/lisp/erc/erc-scenarios-misc-commands.el
index d6ed53b5358..da6855caf57 100644
--- a/test/lisp/erc/erc-scenarios-misc-commands.el
+++ b/test/lisp/erc/erc-scenarios-misc-commands.el
@@ -123,4 +123,94 @@
(should (string= (erc-server-user-host (erc-get-server-user "tester"))
"some.host.test.cc"))))))
+;; This tests four related slash commands, /AMSG, /GMSG, /AME, /GME,
+;; the latter three introduced by bug#68401. It mainly asserts
+;; correct routing behavior, especially not sending or inserting
+;; messages in buffers belonging to disconnected sessions. Left
+;; unaddressed are interactions with the `command-indicator' module
+;; (`erc-noncommands-list') and whatever future `echo-message'
+;; implementation manifests out of bug#49860.
+(ert-deftest erc-scenarios-misc-commands--AMSG-GMSG-AME-GME ()
+ (erc-scenarios-common-with-cleanup
+ ((erc-scenarios-common-dialog "commands")
+ (erc-server-flood-penalty 0.1)
+ (dumb-server-foonet (erc-d-run "localhost" t "srv-foonet" 'amsg-foonet))
+ (dumb-server-barnet (erc-d-run "localhost" t "srv-barnet" 'amsg-barnet))
+ (expect (erc-d-t-make-expecter)))
+
+ (ert-info ("Connect to foonet and join #foo")
+ (with-current-buffer
+ (erc :server "127.0.0.1"
+ :port (process-contact dumb-server-foonet :service)
+ :nick "tester")
+ (funcall expect 10 "debug mode")
+ (erc-cmd-JOIN "#foo")))
+
+ (ert-info ("Connect to barnet and join #bar")
+ (with-current-buffer
+ (erc :server "127.0.0.1"
+ :port (process-contact dumb-server-barnet :service)
+ :nick "tester")
+ (funcall expect 10 "debug mode")
+ (erc-cmd-JOIN "#bar")))
+
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#foo"))
+ (funcall expect 10 "welcome"))
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#bar"))
+ (funcall expect 10 "welcome"))
+
+ (ert-info ("/AMSG only sent to issuing context's server")
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/amsg 1 foonet only"))
+ (with-current-buffer "barnet"
+ (erc-scenarios-common-say "/amsg 2 barnet only"))
+ (with-current-buffer "#foo"
+ (funcall expect 10 "<tester> 1 foonet only")
+ (funcall expect 10 "<alice> bob: Our queen and all"))
+ (with-current-buffer "#bar"
+ (funcall expect 10 "<tester> 2 barnet only")
+ (funcall expect 10 "<joe> mike: And secretly to greet")))
+
+ (ert-info ("/AME only sent to issuing context's server")
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/ame 3 foonet only"))
+ (with-current-buffer "barnet"
+ (erc-scenarios-common-say "/ame 4 barnet only"))
+ (with-current-buffer "#foo"
+ (funcall expect 10 "* tester 3 foonet only")
+ (funcall expect 10 "<alice> bob: You have discharged this"))
+ (with-current-buffer "#bar"
+ (funcall expect 10 "* tester 4 barnet only")
+ (funcall expect 10 "<joe> mike: That same Berowne")))
+
+ (ert-info ("/GMSG and /GME sent to all servers")
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/gmsg 5 all nets")
+ (erc-scenarios-common-say "/gme 6 all nets"))
+ (with-current-buffer "#bar"
+ (funcall expect 10 "<tester> 5 all nets")
+ (funcall expect 10 "* tester 6 all nets")
+ (funcall expect 10 "<joe> mike: Mehercle! if their sons")))
+
+ (ert-info ("/GMSG and /GME only sent to connected servers")
+ (with-current-buffer "barnet"
+ (erc-cmd-QUIT "")
+ (funcall expect 10 "ERC finished"))
+ (with-current-buffer "#foo"
+ (funcall expect 10 "<tester> 5 all nets")
+ (funcall expect 10 "* tester 6 all nets")
+ (funcall expect 10 "<alice> bob: Stand you!"))
+ (with-current-buffer "foonet"
+ (erc-scenarios-common-say "/gmsg 7 all live nets")
+ (erc-scenarios-common-say "/gme 8 all live nets"))
+ ;; Message *not* inserted in disconnected buffer.
+ (with-current-buffer "#bar"
+ (funcall expect -0.1 "<tester> 7 all live nets")
+ (funcall expect -0.1 "* tester 8 all live nets")))
+
+ (with-current-buffer "#foo"
+ (funcall expect 10 "<tester> 7 all live nets")
+ (funcall expect 10 "* tester 8 all live nets")
+ (funcall expect 10 "<bob> alice: Live, and be prosperous;"))))
+
;;; erc-scenarios-misc-commands.el ends here
diff --git a/test/lisp/erc/erc-scenarios-misc.el
b/test/lisp/erc/erc-scenarios-misc.el
index 8f6042de5c2..2afa1ce67a4 100644
--- a/test/lisp/erc/erc-scenarios-misc.el
+++ b/test/lisp/erc/erc-scenarios-misc.el
@@ -126,7 +126,7 @@
(erc-d-t-wait-for 10 (get-buffer "foonet"))
(ert-info ("Channel buffer #foo playback received")
- (with-current-buffer (erc-d-t-wait-for 3 (get-buffer "#foo"))
+ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#foo"))
(funcall expect 10 "Excellent workman")))
(ert-info ("Global notices routed to server buffer")
diff --git a/test/lisp/erc/erc-stamp-tests.el b/test/lisp/erc/erc-stamp-tests.el
index ef292ccb618..a49173ffa2f 100644
--- a/test/lisp/erc/erc-stamp-tests.el
+++ b/test/lisp/erc/erc-stamp-tests.el
@@ -20,14 +20,14 @@
;;; Commentary:
;;; Code:
+(require 'erc-stamp)
+(require 'erc-goodies) ; for `erc-make-read-only'
+
(require 'ert-x)
(eval-and-compile
(let ((load-path (cons (ert-resource-directory) load-path)))
(require 'erc-tests-common)))
-(require 'erc-stamp)
-(require 'erc-goodies) ; for `erc-make-read-only'
-
;; These display-oriented tests are brittle because many factors
;; influence how text properties are applied. We should just
;; rework these into full scenarios.
@@ -46,7 +46,7 @@
(with-current-buffer (get-buffer-create "*erc-stamp-tests--insert-right*")
(erc-mode)
- (erc-munge-invisibility-spec)
+ (erc-stamp--manage-local-options-state)
(erc--initialize-markers (point) nil)
(erc-tests-common-init-server-proc "sleep" "1")
@@ -235,7 +235,7 @@
(with-current-buffer (get-buffer-create "*erc-timestamp-intangible*")
(erc-mode)
(erc--initialize-markers (point) nil)
- (erc-munge-invisibility-spec)
+ (erc-stamp--manage-local-options-state)
(erc-display-message nil 'notice (current-buffer) "Welcome")
;;
;; Pretend `fill' is active and that these lines are
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index b51bd67ae04..085b063bdb2 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -20,13 +20,13 @@
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
+(require 'erc-ring)
(require 'ert-x)
(eval-and-compile
(let ((load-path (cons (ert-resource-directory) load-path)))
(require 'erc-tests-common)))
-(require 'erc-ring)
(ert-deftest erc--read-time-period ()
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "")))
@@ -302,6 +302,7 @@
(cl-incf counter))))
erc-accidental-paste-threshold-seconds
erc-insert-modify-hook
+ (erc-last-input-time 0)
(erc-modules (remq 'stamp erc-modules))
(erc-send-input-line-function #'ignore)
(erc--input-review-functions erc--input-review-functions)
@@ -1053,7 +1054,8 @@
(ert-deftest erc--get-isupport-entry ()
(let ((erc--isupport-params (make-hash-table))
- (erc-server-parameters '(("FOO" . "1") ("BAR") ("BAZ" . "A,B,C")))
+ (erc-server-parameters '(("FOO" . "1") ("BAR") ("BAZ" . "A,B,C")
+ ("SPAM" . "")))
(items (lambda ()
(cl-loop for k being the hash-keys of erc--isupport-params
using (hash-values v) collect (cons k v)))))
@@ -1074,7 +1076,9 @@
(should (equal (erc--get-isupport-entry 'FOO) '(FOO "1")))
(should (equal (funcall items)
- '((BAR . --empty--) (BAZ "A" "B" "C") (FOO "1"))))))
+ '((BAR . --empty--) (BAZ "A" "B" "C") (FOO "1"))))
+ (should (equal (erc--get-isupport-entry 'SPAM) '(SPAM)))
+ (should-not (erc--get-isupport-entry 'SPAM 'single))))
(ert-deftest erc-server-005 ()
(let* ((hooked 0)
@@ -1092,34 +1096,41 @@
(lambda (_ _ _ line) (push line calls))))
(ert-info ("Baseline")
- (setq args '("tester" "BOT=B" "EXCEPTS" "PREFIX=(ov)@+" "are supp...")
+ (setq args '("tester" "BOT=B" "CHANTYPES=" "EXCEPTS" "PREFIX=(ov)@+"
+ "are supp...")
parsed (make-erc-response :command-args args :command "005"))
(setq verify
(lambda ()
(should (equal erc-server-parameters
'(("PREFIX" . "(ov)@+") ("EXCEPTS")
+ ;; Should be ("CHANTYPES") but
+ ;; retained for compatibility.
+ ("CHANTYPES" . "")
("BOT" . "B"))))
(should (zerop (hash-table-count erc--isupport-params)))
(should (equal "(ov)@+" (erc--get-isupport-entry 'PREFIX t)))
(should (equal '(EXCEPTS) (erc--get-isupport-entry 'EXCEPTS)))
(should (equal "B" (erc--get-isupport-entry 'BOT t)))
- (should (string= (pop calls)
- "BOT=B EXCEPTS PREFIX=(ov)@+ are supp..."))
+ (should (string=
+ (pop calls)
+ "BOT=B CHANTYPES= EXCEPTS PREFIX=(ov)@+ are supp..."))
(should (equal args (erc-response.command-args parsed)))))
(erc-call-hooks nil parsed))
(ert-info ("Negated, updated")
- (setq args '("tester" "-EXCEPTS" "-FAKE" "PREFIX=(ohv)@%+" "are su...")
+ (setq args '("tester" "-EXCEPTS" "-CHANTYPES" "-FAKE" "PREFIX=(ohv)@%+"
+ "are su...")
parsed (make-erc-response :command-args args :command "005"))
(setq verify
(lambda ()
(should (equal erc-server-parameters
'(("PREFIX" . "(ohv)@%+") ("BOT" . "B"))))
- (should (string= (pop calls)
- "-EXCEPTS -FAKE PREFIX=(ohv)@%+ are su..."))
+ (should (string-prefix-p
+ "-EXCEPTS -CHANTYPES -FAKE PREFIX=(ohv)@%+ "
+ (pop calls)))
(should (equal "(ohv)@%+" (erc--get-isupport-entry 'PREFIX t)))
(should (equal "B" (erc--get-isupport-entry 'BOT t)))
(should-not (erc--get-isupport-entry 'EXCEPTS))
@@ -1156,25 +1167,37 @@
(should (equal (erc-downcase "\\O/") "|o/" )))))
(ert-deftest erc-channel-p ()
- (let ((erc--isupport-params (make-hash-table))
- erc-server-parameters)
-
- (should (erc-channel-p "#chan"))
- (should (erc-channel-p "##chan"))
- (should (erc-channel-p "&chan"))
- (should (erc-channel-p "+chan"))
- (should (erc-channel-p "!chan"))
- (should-not (erc-channel-p "@chan"))
-
- (push '("CHANTYPES" . "#&@+!") erc-server-parameters)
+ (erc-tests-common-make-server-buf)
- (should (erc-channel-p "!chan"))
- (should (erc-channel-p "#chan"))
+ (should (erc-channel-p "#chan"))
+ (should (erc-channel-p "##chan"))
+ (should (erc-channel-p "&chan"))
+ (should-not (erc-channel-p "+chan"))
+ (should-not (erc-channel-p "!chan"))
+ (should-not (erc-channel-p "@chan"))
+
+ ;; Server sends "CHANTYPES=#&+!"
+ (should-not erc-server-parameters)
+ (setq erc-server-parameters '(("CHANTYPES" . "#&+!")))
+ (should (erc-channel-p "#chan"))
+ (should (erc-channel-p "&chan"))
+ (should (erc-channel-p "+chan"))
+ (should (erc-channel-p "!chan"))
+
+ (with-current-buffer (erc--open-target "#chan")
+ (should (erc-channel-p (current-buffer))))
+ (with-current-buffer (erc--open-target "+chan")
+ (should (erc-channel-p (current-buffer))))
+ (should (erc-channel-p (get-buffer "#chan")))
+ (should (erc-channel-p (get-buffer "+chan")))
+
+ ;; Server sends "CHANTYPES=" because it's query only.
+ (puthash 'CHANTYPES '("CHANTYPES") erc--isupport-params)
+ (should-not (erc-channel-p "#spam"))
+ (should-not (erc-channel-p "&spam"))
+ (should-not (erc-channel-p (save-excursion (erc--open-target "#spam"))))
- (with-current-buffer (get-buffer-create "#chan")
- (setq erc--target (erc--target-from-string "#chan")))
- (should (erc-channel-p (get-buffer "#chan"))))
- (kill-buffer "#chan"))
+ (erc-tests-common-kill-buffers))
(ert-deftest erc--valid-local-channel-p ()
(ert-info ("Local channels not supported")
@@ -1189,12 +1212,16 @@
(should (erc--valid-local-channel-p "&local")))))
(ert-deftest erc--restore-initialize-priors ()
+ (unless (>= emacs-major-version 28)
+ (ert-skip "Lisp nesting exceeds `max-lisp-eval-depth'"))
(should (pcase (macroexpand-1 '(erc--restore-initialize-priors erc-my-mode
foo (ignore 1 2 3)
bar #'spam
baz nil))
(`(let* ((,p (or erc--server-reconnecting erc--target-priors))
(,q (and ,p (alist-get 'erc-my-mode ,p))))
+ (unless (local-variable-if-set-p 'erc-my-mode)
+ (error "Not a local minor mode var: %s" 'erc-my-mode))
(setq foo (if ,q (alist-get 'foo ,p) (ignore 1 2 3))
bar (if ,q (alist-get 'bar ,p) #'spam)
baz (if ,q (alist-get 'baz ,p) nil)))
@@ -1273,7 +1300,7 @@
(setq erc-server-current-nick "tester")
(setq-local erc-last-input-time 0)
(should-not (local-variable-if-set-p 'erc-send-completed-hook))
- (set (make-local-variable 'erc-send-completed-hook) nil) ; skip t (globals)
+ (setq-local erc-send-completed-hook nil) ; skip t (globals)
;; Just in case erc-ring-mode is already on
(setq-local erc--input-review-functions erc--input-review-functions)
(add-hook 'erc--input-review-functions #'erc-add-to-input-ring)
diff --git a/test/lisp/erc/resources/base/upstream-reconnect/znc-severed.eld
b/test/lisp/erc/resources/base/upstream-reconnect/znc-severed.eld
new file mode 100644
index 00000000000..32d05cc8a3a
--- /dev/null
+++ b/test/lisp/erc/resources/base/upstream-reconnect/znc-severed.eld
@@ -0,0 +1,87 @@
+;; -*- mode: lisp-data; -*-
+((pass 10 "PASS :changeme"))
+((nick 10 "NICK tester"))
+((user 10 "USER tester@vanilla/foonet 0 * :tester")
+ (0.00 ":irc.znc.in 001 tester :Welcome to ZNC")
+ (0.03 ":*status!znc@znc.in PRIVMSG tester :Connection Refused.
Reconnecting...")
+ (0.01 ":*status!znc@znc.in PRIVMSG tester :Connection Refused.
Reconnecting...")
+ (0.00 ":*status!znc@znc.in PRIVMSG tester :Connection Refused.
Reconnecting...")
+ (0.01 ":*status!znc@znc.in PRIVMSG tester :Connected!")
+ (0.02 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running
version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Wed, 31 Jan 2024
10:58:16 UTC")
+ (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios
CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii
CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=#
CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by
this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4
MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+
TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100
TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by
this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1
server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")
+ (0.00 ":irc.foonet.org 221 tester +Zi")
+ (0.00 ":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."))
+
+((mode 10 "MODE tester +i")
+ (0.01 ":irc.foonet.org 352 tester * ~u pfa3tpa5ig5ty.irc irc.foonet.org
tester H :0 ZNC - https://znc.in";)
+ (0.01 ":irc.foonet.org 315 tester tester :End of WHO list")
+
+ (0.02 ":tester!~u@pfa3tpa5ig5ty.irc JOIN #chan")
+ (0.03 ":irc.foonet.org 353 tester = #chan :bob tester @alice eve"))
+
+((mode 10 "MODE #chan")
+ (0.00 ":irc.foonet.org 366 tester #chan :End of NAMES list")
+ (0.00 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
+ (0.01 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
+ (0.01 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: And see how he will
take it at your hands.")
+ (0.02 ":irc.foonet.org 221 tester +Zi")
+ (0.01 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Fear not, my lord,
your servant shall do so.")
+ (0.02 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: If I thrive well, I'll
visit thee again.")
+ (0.01 ":irc.foonet.org 324 tester #chan +Cnt")
+ (0.03 ":irc.foonet.org 329 tester #chan 1706698713")
+ (0.05 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Let it be forbid, sir;
so should I be a great deal of his act.")
+ (0.04 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: And see a fearful
sight of blood and death.")
+ (0.00 ":eve!~u@euegh6mj3y8r2.irc PRIVMSG #chan :hola")
+ (0.01 ":eve!~u@euegh6mj3y8r2.irc NICK :Evel")
+ (0.01 ":Evel!~u@euegh6mj3y8r2.irc PRIVMSG #chan :hell o")
+ (0.02 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: His highness comes
post from Marseilles, of as able body as when he numbered thirty: he will be
here to-morrow, or I am deceived by him that in such intelligence hath seldom
failed.")
+ (0.03 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: See, by good hap,
yonder's my lord; I have sweat to see his honour.")
+ (0.02 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: With the rich worth of
your virginity.")
+
+ (0.02 ":*status!znc@znc.in PRIVMSG tester :Disconnected from IRC.
Reconnecting...")
+ (0.05 ":*status!znc@znc.in PRIVMSG tester :Connection Refused.
Reconnecting...")
+ (0.03 ":*status!znc@znc.in PRIVMSG tester :Connected!")
+ (0.01 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0.04 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running
version ergo-v2.11.1")
+ (0.01 ":irc.foonet.org 003 tester :This server was created Wed, 31 Jan 2024
10:58:16 UTC")
+ (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios
CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0.03 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii
CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=#
CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by
this server")
+ (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4
MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+
TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100
TOPICLEN=390 UTF8ONLY WHOX :are supported by this server")
+ (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by
this server")
+ (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1
server(s)")
+ (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0.00 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")
+ (0.02 ":irc.foonet.org 221 tester +i")
+ (0.01 ":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.02 ":irc.foonet.org 352 tester * ~u hrn2ea3rpeyck.irc irc.foonet.org
tester H :0 ZNC - https://znc.in";)
+ (0.01 ":irc.foonet.org 315 tester tester :End of WHO list")
+ (0.02 ":tester!~u@hrn2ea3rpeyck.irc JOIN #chan"))
+
+((mode 10 "MODE #chan")
+ (0.00 ":irc.foonet.org 353 tester = #chan :tester @alice bob")
+ (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list")
+ (0.00 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
+ (0.01 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :tester, welcome!")
+ (0.02 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Nay, I assure you, a
peace concluded.")
+ (0.03 ":irc.foonet.org 324 tester #chan +Cnt")
+ (0.01 ":irc.foonet.org 329 tester #chan 1706698713")
+ (0.05 ":bob!~u@euegh6mj3y8r2.irc PRIVMSG #chan :alice: But, in defence, by
mercy, 'tis most just.")
+ (0.04 ":alice!~u@euegh6mj3y8r2.irc PRIVMSG #chan :bob: Or to drown my
clothes, and say I was stripped."))
diff --git a/test/lisp/erc/resources/commands/amsg-barnet.eld
b/test/lisp/erc/resources/commands/amsg-barnet.eld
new file mode 100644
index 00000000000..53b3e18651a
--- /dev/null
+++ b/test/lisp/erc/resources/commands/amsg-barnet.eld
@@ -0,0 +1,54 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :unknown")
+ (0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester")
+ (0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version
oragono-2.6.0-7481bf0385b95b16")
+ (0 ":irc.barnet.org 003 tester :This server was created Tue, 04 May 2021
05:06:19 UTC")
+ (0 ":irc.barnet.org 004 tester irc.barnet.org oragono-2.6.0-7481bf0385b95b16
BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0 ":irc.barnet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii
CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=#
ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this
server")
+ (0 ":irc.barnet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100
NETWORK=barnet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+
TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100
TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server")
+ (0 ":irc.barnet.org 005 tester draft/CHATHISTORY=100 :are supported by this
server")
+ (0 ":irc.barnet.org 251 tester :There are 0 users and 3 invisible on 1
server(s)")
+ (0 ":irc.barnet.org 252 tester 0 :IRC Operators online")
+ (0 ":irc.barnet.org 253 tester 0 :unregistered connections")
+ (0 ":irc.barnet.org 254 tester 1 :channels formed")
+ (0 ":irc.barnet.org 255 tester :I have 3 clients and 0 servers")
+ (0 ":irc.barnet.org 265 tester 3 3 :Current local users 3, max 3")
+ (0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3")
+ (0 ":irc.barnet.org 422 tester :MOTD File is missing"))
+
+((mode-user 10 "MODE tester +i")
+ (0 ":irc.barnet.org 221 tester +i")
+ (0 ":irc.barnet.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."))
+
+((join 10 "JOIN #bar")
+ (0 ":tester!~u@jnu48g2wrycbw.irc JOIN #bar")
+ (0 ":irc.barnet.org 353 tester = #bar :@mike joe tester")
+ (0 ":irc.barnet.org 366 tester #bar :End of NAMES list"))
+
+((mode-bar 10 "MODE #bar")
+ (0 ":irc.barnet.org 324 tester #bar +nt")
+ (0 ":irc.barnet.org 329 tester #bar 1620104779")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :tester, welcome!")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :tester, welcome!")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: Whipp'd first, sir, and
hang'd after.")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: We have yet many among us
can gripe as hard as Cassibelan; I do not say I am one, but I have a hand. Why
tribute ? why should we pay tribute ? If C sar can hide the sun from us with a
blanket, or put the moon in his pocket, we will pay him tribute for light;
else, sir, no more tribute, pray you now."))
+
+((privmsg-2 10 "PRIVMSG #bar :2 barnet only")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: Double and treble
admonition, and still forfeit in the same kind ? This would make mercy swear,
and play the tyrant.")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: And secretly to greet the
empress' friends."))
+
+((privmsg-4 10 "PRIVMSG #bar :\1ACTION 4 barnet only\1")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: You have not been
inquired after: I have sat here all day.")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: That same Berowne I'll
torture ere I go."))
+
+((privmsg-5 10 "PRIVMSG #bar :5 all nets"))
+
+((privmsg-6 10 "PRIVMSG #bar :\1ACTION 6 all nets\1")
+ (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :joe: For mine own part,no
offence to the general, nor any man of quality,I hope to be saved.")
+ (0.1 ":joe!~u@kd7gmjbnbkn8c.irc PRIVMSG #bar :mike: Mehercle! if their sons
be ingenuous, they shall want no instruction; if their daughters be capable, I
will put it to them. But, vir sapit qui pauca loquitur. A soul feminine
saluteth us."))
+
+((quit 5 "QUIT :\2ERC\2")
+ (0 ":tester!~u@jnu48g2wrycbw.irc QUIT :Quit"))
+
+((drop 0 DROP))
diff --git a/test/lisp/erc/resources/commands/amsg-foonet.eld
b/test/lisp/erc/resources/commands/amsg-foonet.eld
new file mode 100644
index 00000000000..eb3d84d646a
--- /dev/null
+++ b/test/lisp/erc/resources/commands/amsg-foonet.eld
@@ -0,0 +1,56 @@
+;; -*- mode: lisp-data; -*-
+((nick 10 "NICK tester"))
+((user 10 "USER user 0 * :unknown")
+ (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester")
+ (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version
oragono-2.6.0-7481bf0385b95b16")
+ (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021
05:06:18 UTC")
+ (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16
BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv")
+ (0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii
CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=#
ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this
server")
+ (0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100
NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+
TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100
TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server")
+ (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this
server")
+ (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1
server(s)")
+ (0 ":irc.foonet.org 252 tester 0 :IRC Operators online")
+ (0 ":irc.foonet.org 253 tester 0 :unregistered connections")
+ (0 ":irc.foonet.org 254 tester 1 :channels formed")
+ (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers")
+ (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3")
+ (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 10 "MODE tester +i")
+ (0 ":irc.foonet.org 221 tester +i")
+ (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."))
+
+((join 10 "JOIN #foo")
+ (0 ":tester!~u@9g6b728983yd2.irc JOIN #foo")
+ (0 ":irc.foonet.org 353 tester = #foo :alice tester @bob")
+ (0 ":irc.foonet.org 366 tester #foo :End of NAMES list"))
+
+((mode-foo 10 "MODE #foo")
+ (0 ":irc.foonet.org 324 tester #foo +nt")
+ (0 ":irc.foonet.org 329 tester #foo 1620104779")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :tester, welcome!")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :tester, welcome!")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: But, as it seems, did
violence on herself.")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: Well, this is the forest
of Arden."))
+
+((privmsg-1 10 "PRIVMSG #foo :1 foonet only")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Signior Iachimo will not
from it. Pray, let us follow 'em.")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: Our queen and all her
elves come here anon."))
+
+((privmsg-3 10 "PRIVMSG #foo :\1ACTION 3 foonet only\1")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: The ground is bloody;
search about the churchyard.")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: You have discharged this
honestly: keep it to yourself. Many likelihoods informed me of this before,
which hung so tottering in the balance that I could neither believe nor
misdoubt. Pray you, leave me: stall this in your bosom; and I thank you for
your honest care. I will speak with you further anon."))
+
+((privmsg-5 10 "PRIVMSG #foo :5 all nets"))
+
+((privmsg-6 10 "PRIVMSG #foo :\1ACTION 6 all nets\1")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Give me that mattock,
and the wrenching iron.")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: Stand you! You have land
enough of your own; but he added to your having, gave you some ground."))
+
+((privmsg-6 10 "PRIVMSG #foo :7 all live nets")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Excellent workman! Thou
canst not paint a man so bad as is thyself."))
+
+((privmsg-6 10 "PRIVMSG #foo :\1ACTION 8 all live nets\1")
+ (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #foo :bob: And will you, being a
man of your breeding, be married under a bush, like a beggar ? Get you to
church, and have a good priest that can tell you what marriage is: this fellow
will but join you together as they join wainscot; then one of you will prove a
shrunk panel, and like green timber, warp, warp.")
+ (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #foo :alice: Live, and be prosperous;
and farewell, good fellow."))
diff --git a/test/lisp/erc/resources/erc-scenarios-common.el
b/test/lisp/erc/resources/erc-scenarios-common.el
index 0ec48d766ef..9ad5ce49429 100644
--- a/test/lisp/erc/resources/erc-scenarios-common.el
+++ b/test/lisp/erc/resources/erc-scenarios-common.el
@@ -94,7 +94,8 @@
(require 'erc)
(eval-when-compile (require 'erc-join)
- (require 'erc-services))
+ (require 'erc-services)
+ (require 'erc-fill))
(declare-function erc-network "erc-networks")
(defvar erc-network)
@@ -148,9 +149,11 @@
(timer-list (copy-sequence timer-list))
(timer-idle-list (copy-sequence timer-idle-list))
(erc-auth-source-parameters-join-function nil)
+ (erc--fill-wrap-scrolltobottom-exempt-p t)
(erc-autojoin-channels-alist nil)
(erc-server-auto-reconnect nil)
(erc-after-connect nil)
+ (erc-last-input-time 0)
(erc-d-linger-secs 10)
,@bindings)))
diff --git a/test/lisp/erc/resources/erc-tests-common.el
b/test/lisp/erc/resources/erc-tests-common.el
index 05dbe1d50d6..99f15b89b03 100644
--- a/test/lisp/erc/resources/erc-tests-common.el
+++ b/test/lisp/erc/resources/erc-tests-common.el
@@ -122,7 +122,7 @@ Use NAME for the network and the session server as well."
erc--isupport-params (make-hash-table)
erc-session-port 6667
erc-network (intern name)
- erc-networks--id (erc-networks--id-create nil))
+ erc-networks--id (erc-networks--id-create name))
(current-buffer)))
(defun erc-tests-common-string-to-propertized-parts (string)
diff --git a/test/lisp/eshell/esh-opt-tests.el
b/test/lisp/eshell/esh-opt-tests.el
index 8d6e0c1e426..4e5373e53cd 100644
--- a/test/lisp/eshell/esh-opt-tests.el
+++ b/test/lisp/eshell/esh-opt-tests.el
@@ -29,13 +29,15 @@
(eshell--process-args
"sudo" '("-a")
'((?a "all" nil show-all
- "do not ignore entries starting with .")))))
+ "do not ignore entries starting with ."))
+ '(show-all))))
(should
(equal '("root" "world")
(eshell--process-args
"sudo" '("-u" "root" "world")
'((?u "user" t user
- "execute a command as another USER"))))))
+ "execute a command as another USER"))
+ '(user)))))
(ert-deftest esh-opt-test/process-args-parse-leading-options-only ()
"Test behavior of :parse-leading-options-only in `eshell--process-args'."
@@ -45,20 +47,23 @@
"sudo" '("emerge" "-uDN" "world")
'((?u "user" t user
"execute a command as another USER")
- :parse-leading-options-only))))
+ :parse-leading-options-only)
+ '(user))))
(should
(equal '("root" "emerge" "-uDN" "world")
(eshell--process-args
"sudo" '("-u" "root" "emerge" "-uDN" "world")
'((?u "user" t user
"execute a command as another USER")
- :parse-leading-options-only))))
+ :parse-leading-options-only)
+ '(user))))
(should
(equal '("DN" "emerge" "world")
(eshell--process-args
"sudo" '("-u" "root" "emerge" "-uDN" "world")
'((?u "user" t user
- "execute a command as another USER"))))))
+ "execute a command as another USER"))
+ '(user)))))
(ert-deftest esh-opt-test/process-args-external ()
"Test behavior of :external in `eshell--process-args'."
@@ -69,7 +74,8 @@
"ls" '("/some/path")
'((?a "all" nil show-all
"do not ignore entries starting with .")
- :external "ls")))))
+ :external "ls")
+ '(show-all)))))
(cl-letf (((symbol-function 'eshell-search-path) #'identity))
(should
(equal '(no-catch eshell-ext-command "ls")
@@ -78,7 +84,8 @@
"ls" '("-u" "/some/path")
'((?a "all" nil show-all
"do not ignore entries starting with .")
- :external "ls"))
+ :external "ls")
+ '(show-all))
:type 'no-catch))))
(cl-letf (((symbol-function 'eshell-search-path) #'ignore))
(should-error
@@ -86,7 +93,8 @@
"ls" '("-u" "/some/path")
'((?a "all" nil show-all
"do not ignore entries starting with .")
- :external "ls"))
+ :external "ls")
+ '(show-all))
:type 'error)))
(ert-deftest esh-opt-test/eval-using-options-short ()
diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el
index e01e033e25e..e58b5a14ed9 100644
--- a/test/lisp/eshell/eshell-tests.el
+++ b/test/lisp/eshell/eshell-tests.el
@@ -153,7 +153,7 @@ insert the queued one at the next prompt, and finally run
it."
"Test flushing of previous output"
(with-temp-eshell
(eshell-insert-command "echo alpha")
- (eshell-kill-output)
+ (eshell-delete-output)
(should (eshell-match-output
(concat "^" (regexp-quote "*** output flushed ***\n") "$")))))
diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el
index 11af1f75574..28f4d5fa181 100644
--- a/test/lisp/filenotify-tests.el
+++ b/test/lisp/filenotify-tests.el
@@ -74,8 +74,8 @@
(defvar file-notify--test-events nil)
(defvar file-notify--test-monitors nil)
-(defun file-notify--test-read-event ()
- "Read one event.
+(defun file-notify--test-wait-event ()
+ "Wait for one event.
There are different timeouts for local and remote file notification libraries."
(read-event
nil nil
@@ -87,7 +87,8 @@ There are different timeouts for local and remote file
notification libraries."
;; for any monitor.
((file-notify--test-monitor) 7)
((file-remote-p temporary-file-directory) 0.1)
- (t 0.01))))
+ (t 0.01)))
+ nil)
(defun file-notify--test-timeout ()
"Timeout to wait for arriving a bunch of events, in seconds."
@@ -103,7 +104,7 @@ There are different timeouts for local and remote file
notification libraries."
TIMEOUT is the maximum time to wait for, in seconds."
`(with-timeout (,timeout (ignore))
(while (null ,until)
- (file-notify--test-read-event))))
+ (file-notify--test-wait-event))))
(defun file-notify--test-no-descriptors ()
"Check that `file-notify-descriptors' is an empty hash table.
@@ -452,7 +453,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; Check, that removing watch descriptors out of order do not
;; harm. This fails on cygwin because of timing issues unless a
;; long `sit-for' is added before the call to
- ;; `file-notify--test-read-event'.
+ ;; `file-notify--test-wait-event'.
(unless (eq system-type 'cygwin)
(let (results)
(cl-flet ((first-callback (event)
@@ -480,7 +481,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'."
;; Remove first watch.
(file-notify-rm-watch file-notify--test-desc)
;; Only the second callback shall run.
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile)
(file-notify--test-wait-for-events
(file-notify--test-timeout) results)
@@ -622,7 +623,7 @@ delivered."
(cons 'file-notify while-no-input-ignore-events))
create-lockfiles)
;; Flush pending actions.
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(file-notify--test-wait-for-events
(file-notify--test-timeout)
(not (input-pending-p)))
@@ -671,7 +672,7 @@ delivered."
(t '(created changed deleted stopped)))
(write-region
"another text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile))
(file-notify-rm-watch file-notify--test-desc)
@@ -707,7 +708,7 @@ delivered."
(changed changed deleted stopped))))
(write-region
"another text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile))
(file-notify-rm-watch file-notify--test-desc)
@@ -755,7 +756,7 @@ delivered."
(t '(created changed deleted deleted stopped)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-directory file-notify--test-tmpdir 'recursive))
(file-notify-rm-watch file-notify--test-desc)
@@ -805,14 +806,14 @@ delivered."
deleted deleted deleted stopped)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(copy-file file-notify--test-tmpfile file-notify--test-tmpfile1)
;; The next two events shall not be visible.
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(set-file-modes file-notify--test-tmpfile 000 'nofollow)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(set-file-times file-notify--test-tmpfile '(0 0) 'nofollow)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-directory file-notify--test-tmpdir 'recursive))
(file-notify-rm-watch file-notify--test-desc)
@@ -860,10 +861,10 @@ delivered."
(t '(created changed renamed deleted deleted stopped)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(rename-file file-notify--test-tmpfile file-notify--test-tmpfile1)
;; After the rename, we won't get events anymore.
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-directory file-notify--test-tmpdir 'recursive))
(file-notify-rm-watch file-notify--test-desc)
@@ -912,11 +913,11 @@ delivered."
(t '(attribute-changed attribute-changed)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(set-file-modes file-notify--test-tmpfile 000 'nofollow)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(set-file-times file-notify--test-tmpfile '(0 0) 'nofollow)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile))
(file-notify-rm-watch file-notify--test-desc)
@@ -1087,7 +1088,7 @@ delivered."
(changed changed deleted stopped))))
(write-region
"another text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file-notify--test-tmpfile))
;; After deleting the file, the descriptor is not valid anymore.
(should-not (file-notify-valid-p file-notify--test-desc))
@@ -1134,7 +1135,7 @@ delivered."
(t '(created changed deleted deleted stopped)))
(write-region
"any text" nil file-notify--test-tmpfile nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-directory file-notify--test-tmpdir 'recursive))
;; After deleting the parent directory, the descriptor must
;; not be valid anymore.
@@ -1247,9 +1248,9 @@ delivered."
(let ((source-file-list source-file-list)
(target-file-list target-file-list))
(while (and source-file-list target-file-list)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(write-region "" nil (pop source-file-list) nil 'no-message)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(write-region "" nil (pop target-file-list) nil 'no-message))))
(file-notify--test-with-actions
(cond
@@ -1272,11 +1273,11 @@ delivered."
(let ((source-file-list source-file-list)
(target-file-list target-file-list))
(while (and source-file-list target-file-list)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(rename-file (pop source-file-list) (pop target-file-list) t))))
(file-notify--test-with-actions (make-list n 'deleted)
(dolist (file target-file-list)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(delete-file file)))
(delete-directory file-notify--test-tmpfile)
(if (or (string-equal (file-notify--test-library) "w32notify")
@@ -1464,7 +1465,7 @@ the file watch."
;; does not report the `changed' event.
(make-list (/ n 2) 'created)))
(dotimes (i n)
- (file-notify--test-read-event)
+ (file-notify--test-wait-event)
(if (zerop (mod i 2))
(write-region
"any text" nil file-notify--test-tmpfile1 t 'no-message)
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el
index 718ecd51f8b..d4c1ef3ba67 100644
--- a/test/lisp/files-tests.el
+++ b/test/lisp/files-tests.el
@@ -1656,30 +1656,47 @@ The door of all subtleties!
(should (equal (file-name-base "foo") "foo"))
(should (equal (file-name-base "foo/bar") "bar")))
-(defun files-tests--check-shebang (shebang expected-mode)
- "Assert that mode for SHEBANG derives from EXPECTED-MODE."
- (let ((actual-mode
- (ert-with-temp-file script-file
- :text shebang
- (find-file script-file)
- (if (derived-mode-p expected-mode)
- expected-mode
- major-mode))))
- ;; Tuck all the information we need in the `should' form: input
- ;; shebang, expected mode vs actual.
- (should
- (equal (list shebang actual-mode)
- (list shebang expected-mode)))))
+(defvar sh-shell)
+
+(defun files-tests--check-shebang (shebang expected-mode &optional
expected-dialect)
+ "Assert that mode for SHEBANG derives from EXPECTED-MODE.
+
+If EXPECTED-MODE is sh-base-mode, DIALECT says what `sh-shell' should be
+set to."
+ (ert-with-temp-file script-file
+ :text shebang
+ (find-file script-file)
+ (let ((actual-mode (if (derived-mode-p expected-mode)
+ expected-mode
+ major-mode)))
+ ;; Tuck all the information we need in the `should' form: input
+ ;; shebang, expected mode vs actual.
+ (should
+ (equal (list shebang actual-mode)
+ (list shebang expected-mode)))
+ (when (eq expected-mode 'sh-base-mode)
+ (should (eq sh-shell expected-dialect))))))
(ert-deftest files-tests-auto-mode-interpreter ()
"Test that `set-auto-mode' deduces correct modes from shebangs."
- (files-tests--check-shebang "#!/bin/bash" 'sh-mode)
- (files-tests--check-shebang "#!/usr/bin/env bash" 'sh-mode)
+ ;; Straightforward interpreter invocation.
+ (files-tests--check-shebang "#!/bin/bash" 'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/make -f" 'makefile-mode)
+ ;; Invocation through env.
+ (files-tests--check-shebang "#!/usr/bin/env bash" 'sh-base-mode 'bash)
(files-tests--check-shebang "#!/usr/bin/env python" 'python-base-mode)
(files-tests--check-shebang "#!/usr/bin/env python3" 'python-base-mode)
+ ;; Invocation through env, with supplementary arguments.
+ (files-tests--check-shebang "#!/usr/bin/env --split-string=bash -eux"
'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/env --split-string=-iv
--default-signal bash -eux" 'sh-base-mode 'bash)
(files-tests--check-shebang "#!/usr/bin/env -S awk -v FS=\"\\t\" -v
OFS=\"\\t\" -f" 'awk-mode)
(files-tests--check-shebang "#!/usr/bin/env -S make -f" 'makefile-mode)
- (files-tests--check-shebang "#!/usr/bin/make -f" 'makefile-mode))
+ (files-tests--check-shebang "#!/usr/bin/env -S-vi bash -eux" 'sh-base-mode
'bash)
+ (files-tests--check-shebang "#!/usr/bin/env -ivS --default-signal=INT bash
-eux" 'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/env -ivS --default-signal bash -eux"
'sh-base-mode 'bash)
+ (files-tests--check-shebang "#!/usr/bin/env -vS -uFOOBAR bash -eux"
'sh-base-mode 'bash)
+ ;; Invocation through env, with modified environment.
+ (files-tests--check-shebang "#!/usr/bin/env -S PYTHONPATH=/...:${PYTHONPATH}
python" 'python-base-mode))
(ert-deftest files-test-dir-locals-auto-mode-alist ()
"Test an `auto-mode-alist' entry in `.dir-locals.el'"
diff --git a/test/lisp/info-tests.el b/test/lisp/info-tests.el
index 0dfdbf417e8..8020a7419cf 100644
--- a/test/lisp/info-tests.el
+++ b/test/lisp/info-tests.el
@@ -28,18 +28,20 @@
(require 'ert-x)
(ert-deftest test-info-urls ()
+ (should (equal (Info-url-for-node "(tramp)Top")
+ "https://www.gnu.org/software/emacs/manual/html_node/tramp/";))
(should (equal (Info-url-for-node "(emacs)Minibuffer")
-
"https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer";))
+
"https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer.html";))
(should (equal (Info-url-for-node "(emacs)Minibuffer File")
-
"https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer-File";))
+
"https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer-File.html";))
(should (equal (Info-url-for-node "(elisp)Backups and Auto-Saving")
-
"https://www.gnu.org/software/emacs/manual/html_node/elisp/Backups-and-Auto_002dSaving";))
+
"https://www.gnu.org/software/emacs/manual/html_node/elisp/Backups-and-Auto_002dSaving.html";))
(should (equal (Info-url-for-node "(eintr)car & cdr")
-
"https://www.gnu.org/software/emacs/manual/html_node/eintr/car-_0026-cdr";))
+
"https://www.gnu.org/software/emacs/manual/html_node/eintr/car-_0026-cdr.html";))
(should (equal (Info-url-for-node "(emacs-mime)\tIndex")
-
"https://www.gnu.org/software/emacs/manual/html_node/emacs-mime/Index";))
- (should (equal (Info-url-for-node "(gnus) Don't Panic")
-
"https://www.gnu.org/software/emacs/manual/html_node/gnus/Don_0027t-Panic";))
+
"https://www.gnu.org/software/emacs/manual/html_node/emacs-mime/Index.html";))
+ (should (equal (Info-url-for-node "(gnus) Don't Panic")
+
"https://www.gnu.org/software/emacs/manual/html_node/gnus/Don_0027t-Panic.html";))
(should-error (Info-url-for-node "(nonexistent)Example")))
;;; info-tests.el ends here
diff --git a/test/lisp/international/mule-tests.el
b/test/lisp/international/mule-tests.el
index 5c742451a57..9a80ced55ae 100644
--- a/test/lisp/international/mule-tests.el
+++ b/test/lisp/international/mule-tests.el
@@ -96,10 +96,10 @@
;;; Testing `sgml-html-meta-auto-coding-function'.
-(defconst sgml-html-meta-pre "<!doctype html><html><head>"
+(defvar sgml-html-meta-pre "<!doctype html><html><head>"
"The beginning of a minimal HTML document.")
-(defconst sgml-html-meta-post "</head></html>"
+(defvar sgml-html-meta-post "</head></html>"
"The end of a minimal HTML document.")
(defun sgml-html-meta-run (coding-system)
diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el
index 07c4dbc3197..c4a7de9e51f 100644
--- a/test/lisp/minibuffer-tests.el
+++ b/test/lisp/minibuffer-tests.el
@@ -201,6 +201,13 @@
'completions-first-difference)
return pos))
+(ert-deftest completion-test--pcm-bug38458 ()
+ (should (equal (let ((completion-ignore-case t))
+ (completion-pcm--merge-try '("tes" point "ing")
+ '("Testing" "testing")
+ "" ""))
+ '("testing" . 4))))
+
(ert-deftest completion-pcm-test-1 ()
;; Point is at end, this does not match anything
(should (null
diff --git a/test/lisp/net/tramp-archive-tests.el
b/test/lisp/net/tramp-archive-tests.el
index 978342b1bb1..1ca2fa9b9b3 100644
--- a/test/lisp/net/tramp-archive-tests.el
+++ b/test/lisp/net/tramp-archive-tests.el
@@ -77,7 +77,7 @@ A resource file is in the resource directory as per
`ert-resource-directory'."
`(expand-file-name ,file (ert-resource-directory)))))
-(defconst tramp-archive-test-file-archive (ert-resource-file "foo.tar.gz")
+(defvar tramp-archive-test-file-archive (ert-resource-file "foo.tar.gz")
"The test file archive.")
(defun tramp-archive-test-file-archive-hexlified ()
@@ -86,7 +86,7 @@ Do not hexlify \"/\". This hexlified string is used in
`file:///' URLs."
(let* ((url-unreserved-chars (cons ?/ url-unreserved-chars)))
(url-hexify-string tramp-archive-test-file-archive)))
-(defconst tramp-archive-test-archive
+(defvar tramp-archive-test-archive
(file-name-as-directory tramp-archive-test-file-archive)
"The test archive.")
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index 2a3b3e16891..cdd2a1efdb2 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -265,8 +265,8 @@ is greater than 10.
`(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0)))
(debug-ignored-errors
(append
- '("^make-symbolic-link not supported$"
- "^error with add-name-to-file")
+ '("\\`make-symbolic-link not supported\\'"
+ "\\`error with add-name-to-file")
debug-ignored-errors))
inhibit-message)
(unwind-protect
@@ -379,7 +379,7 @@ is greater than 10.
(let (tramp-mode)
(should-not (tramp-tramp-file-p "/method:user@host:")))
;; `tramp-ignored-file-name-regexp' suppresses Tramp.
- (let ((tramp-ignored-file-name-regexp "^/method:user@host:"))
+ (let ((tramp-ignored-file-name-regexp "\\`/method:user@host:"))
(should-not (tramp-tramp-file-p "/method:user@host:")))
;; Methods shall be at least two characters, except the
;; default method.
@@ -3493,6 +3493,8 @@ This tests also `file-directory-p' and
`file-accessible-directory-p'."
(skip-unless (not (tramp--test-rsync-p)))
;; Wildcards are not supported in tramp-crypt.el.
(skip-unless (not (tramp--test-crypt-p)))
+ ;; Wildcards are not supported with "docker cp ..." or "podman cp ...".
+ (skip-unless (not (tramp--test-container-oob-p)))
(dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil)))
(let* ((tmp-name1
@@ -3815,15 +3817,24 @@ This tests also `access-file', `file-readable-p',
(ignore-errors (delete-file tmp-name1))
(ignore-errors (delete-file tmp-name2))))))
+(defun tramp--test-set-ert-test-documentation (test command)
+ "Set the documentation string for a derived test.
+The test is derived from TEST and COMMAND."
+ (let ((test-doc
+ (split-string (ert-test-documentation (get test 'ert--test)) "\n")))
+ ;; The first line must be extended.
+ (setcar
+ test-doc (format "%s Use the \"%s\" command." (car test-doc) command))
+ (setf (ert-test-documentation
+ (get (intern (format "%s-with-%s" test command)) 'ert--test))
+ (string-join test-doc "\n"))))
+
(defmacro tramp--test-deftest-with-stat (test)
"Define ert `TEST-with-stat'."
(declare (indent 1))
`(ert-deftest ,(intern (concat (symbol-name test) "-with-stat")) ()
- ;; This is the docstring. However, it must be expanded to a
- ;; string inside the macro. No idea.
- ;; (concat (ert-test-documentation (get ',test 'ert--test))
- ;; "\nUse the \"stat\" command.")
:tags '(:expensive-test)
+ (tramp--test-set-ert-test-documentation ',test "stat")
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (tramp-get-remote-stat tramp-test-vec))
@@ -3842,11 +3853,8 @@ This tests also `access-file', `file-readable-p',
"Define ert `TEST-with-perl'."
(declare (indent 1))
`(ert-deftest ,(intern (concat (symbol-name test) "-with-perl")) ()
- ;; This is the docstring. However, it must be expanded to a
- ;; string inside the macro. No idea.
- ;; (concat (ert-test-documentation (get ',test 'ert--test))
- ;; "\nUse the \"perl\" command.")
:tags '(:expensive-test)
+ (tramp--test-set-ert-test-documentation ',test "perl")
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(skip-unless (tramp-get-remote-perl tramp-test-vec))
@@ -3870,11 +3878,8 @@ This tests also `access-file', `file-readable-p',
"Define ert `TEST-with-ls'."
(declare (indent 1))
`(ert-deftest ,(intern (concat (symbol-name test) "-with-ls")) ()
- ;; This is the docstring. However, it must be expanded to a
- ;; string inside the macro. No idea.
- ;; (concat (ert-test-documentation (get ',test 'ert--test))
- ;; "\nUse the \"ls\" command.")
:tags '(:expensive-test)
+ (tramp--test-set-ert-test-documentation ',test "ls")
(skip-unless (tramp--test-enabled))
(skip-unless (tramp--test-sh-p))
(if-let ((default-directory ert-remote-temporary-file-directory)
@@ -5155,8 +5160,8 @@ This tests also `make-symbolic-link', `file-truename' and
`add-name-to-file'."
(should-not (get-buffer-window (current-buffer) t))
(delete-file tmp-name)))
- ;; Check remote and local DESTNATION file. This isn't
- ;; implemented yet ina all file name handler backends.
+ ;; Check remote and local DESTINATION file. This isn't
+ ;; implemented yet in all file name handler backends.
;; (dolist (local '(nil t))
;; (setq tmp-name (tramp--test-make-temp-name local quoted))
;; (should
@@ -6376,33 +6381,35 @@ INPUT, if non-nil, is a string sent to the process."
(setq tramp-remote-path orig-tramp-remote-path)
;; We make a super long `tramp-remote-path'.
- (make-directory tmp-name)
- (should (file-directory-p tmp-name))
- (while (tramp-compat-length< (string-join orig-exec-path ":") 5000)
- (let ((dir (make-temp-file (file-name-as-directory tmp-name)
'dir)))
- (should (file-directory-p dir))
- (setq tramp-remote-path
- (append
- tramp-remote-path `(,(file-remote-p dir 'localname)))
- orig-exec-path
- (append
- (butlast orig-exec-path)
- `(,(file-remote-p dir 'localname))
- (last orig-exec-path)))))
- (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
- (should (equal (exec-path) orig-exec-path))
- ;; Ignore trailing newline.
- (setq path (substring (shell-command-to-string "echo $PATH") nil -1))
- ;; The shell doesn't handle such long strings.
- (unless (tramp-compat-length>
- path
- (tramp-get-connection-property
- tramp-test-vec "pipe-buf" 4096))
- ;; The last element of `exec-path' is `exec-directory'.
- (should
- (string-equal path (string-join (butlast orig-exec-path) ":"))))
- ;; The shell "sh" shall always exist.
- (should (executable-find "sh" 'remote)))
+ (unless (tramp--test-container-oob-p)
+ (make-directory tmp-name)
+ (should (file-directory-p tmp-name))
+ (while (tramp-compat-length< (string-join orig-exec-path ":") 5000)
+ (let ((dir (make-temp-file
+ (file-name-as-directory tmp-name) 'dir)))
+ (should (file-directory-p dir))
+ (setq tramp-remote-path
+ (append
+ tramp-remote-path `(,(file-remote-p dir 'localname)))
+ orig-exec-path
+ (append
+ (butlast orig-exec-path)
+ `(,(file-remote-p dir 'localname))
+ (last orig-exec-path)))))
+ (tramp-cleanup-connection tramp-test-vec 'keep-debug
'keep-password)
+ (should (equal (exec-path) orig-exec-path))
+ ;; Ignore trailing newline.
+ (setq path (substring (shell-command-to-string "echo $PATH") nil
-1))
+ ;; The shell doesn't handle such long strings.
+ (unless (tramp-compat-length>
+ path
+ (tramp-get-connection-property
+ tramp-test-vec "pipe-buf" 4096))
+ ;; The last element of `exec-path' is `exec-directory'.
+ (should
+ (string-equal path (string-join (butlast orig-exec-path) ":"))))
+ ;; The shell "sh" shall always exist.
+ (should (executable-find "sh" 'remote))))
;; Cleanup.
(tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password)
@@ -7053,17 +7060,24 @@ This is used in tests which we don't want to tag
(not (and (tramp--test-adb-p)
(string-match-p (rx multibyte) default-directory)))))
-(defun tramp--test-crypt-p ()
- "Check, whether the remote directory is encrypted."
- (tramp-crypt-file-name-p ert-remote-temporary-file-directory))
-
(defun tramp--test-container-p ()
"Check, whether a container method is used.
This does not support some special file names."
(string-match-p
- (rx bol (| "docker" "podman") eol)
+ (rx bol (| "docker" "podman"))
(file-remote-p ert-remote-temporary-file-directory 'method)))
+(defun tramp--test-container-oob-p ()
+ "Check, whether the dockercp or podmancp method is used.
+They does not support wildcard copy."
+ (string-match-p
+ (rx bol (| "dockercp" "podmancp") eol)
+ (file-remote-p ert-remote-temporary-file-directory 'method)))
+
+(defun tramp--test-crypt-p ()
+ "Check, whether the remote directory is encrypted."
+ (tramp-crypt-file-name-p ert-remote-temporary-file-directory))
+
(defun tramp--test-expensive-test-p ()
"Whether expensive tests are run.
This is used in tests which we don't want to tag `:expensive'
@@ -7480,7 +7494,8 @@ This requires restrictions of file name syntax."
(tramp--test-gvfs-p)
(tramp--test-windows-nt-or-smb-p))
"?foo?bar?baz?")
- (unless (or (tramp--test-ftp-p)
+ (unless (or (tramp--test-container-oob-p)
+ (tramp--test-ftp-p)
(tramp--test-gvfs-p)
(tramp--test-windows-nt-or-smb-p))
"*foo+bar*baz+")
@@ -7500,7 +7515,10 @@ This requires restrictions of file name syntax."
(unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p))
"<foo>bar<baz>")
"(foo)bar(baz)"
- (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]")
+ (unless (or (tramp--test-container-oob-p)
+ (tramp--test-ftp-p)
+ (tramp--test-gvfs-p))
+ "[foo]bar[baz]")
"{foo}bar{baz}")))
;; Simplify test in order to speed up.
(apply #'tramp--test-check-files
diff --git a/test/lisp/obarray-tests.el b/test/lisp/obarray-tests.el
index d7e547fcf29..f9f97dba535 100644
--- a/test/lisp/obarray-tests.el
+++ b/test/lisp/obarray-tests.el
@@ -32,27 +32,18 @@
(should-not (obarrayp "aoeu"))
(should-not (obarrayp '()))
(should-not (obarrayp []))
- (should (obarrayp (make-vector 7 0))))
-
-(ert-deftest obarrayp-unchecked-content-test ()
- "Should fail to check content of passed obarray."
- :expected-result :failed
(should-not (obarrayp ["a" "b" "c"]))
- (should-not (obarrayp [1 2 3])))
-
-(ert-deftest obarray-make-default-test ()
- (let ((table (obarray-make)))
- (should (obarrayp table))
- (should (eq (obarray-size table) obarray-default-size))))
+ (should-not (obarrayp [1 2 3]))
+ (should-not (obarrayp (make-vector 7 0)))
+ (should-not (obarrayp (vector (obarray-make))))
+ (should (obarrayp (obarray-make)))
+ (should (obarrayp (obarray-make 7))))
(ert-deftest obarray-make-with-size-test ()
;; FIXME: Actually, `wrong-type-argument' is not the right error to signal,
;; so we shouldn't enforce this misbehavior in tests!
(should-error (obarray-make -1) :type 'wrong-type-argument)
- (should-error (obarray-make 0) :type 'wrong-type-argument)
- (let ((table (obarray-make 1)))
- (should (obarrayp table))
- (should (eq (obarray-size table) 1))))
+ (should-error (obarray-make 'a) :type 'wrong-type-argument))
(ert-deftest obarray-get-test ()
(let ((table (obarray-make 3)))
@@ -88,5 +79,15 @@
(obarray-map collect-names table)
(should (equal (sort syms #'string<) '("a" "b" "c")))))
+(ert-deftest obarray-clear ()
+ (let ((o (obarray-make)))
+ (intern "a" o)
+ (intern "b" o)
+ (intern "c" o)
+ (obarray-clear o)
+ (let ((n 0))
+ (mapatoms (lambda (_) (setq n (1+ n))) o)
+ (should (equal n 0)))))
+
(provide 'obarray-tests)
;;; obarray-tests.el ends here
diff --git a/test/lisp/progmodes/java-ts-mode-resources/indent.erts
b/test/lisp/progmodes/java-ts-mode-resources/indent.erts
index 4fca74dd2e1..514d2e08977 100644
--- a/test/lisp/progmodes/java-ts-mode-resources/indent.erts
+++ b/test/lisp/progmodes/java-ts-mode-resources/indent.erts
@@ -110,3 +110,34 @@ public class Java {
}
}
=-=-=
+
+Name: Opening bracket on separate line (bug#67556)
+
+=-=
+public class Java {
+ void foo(
+ String foo)
+ {
+ for (var f : rs)
+ return new String[]
+ {
+ "foo",
+ "bar"
+ };
+ if (a == 0)
+ {
+ return 0;
+ } else if (a == 1)
+ {
+ return 1;
+ }
+
+ switch(expr)
+ {
+ case x:
+ // code block
+ break;
+ }
+ }
+}
+=-=-=
diff --git a/test/lisp/progmodes/python-tests.el
b/test/lisp/progmodes/python-tests.el
index 59957ff0712..1ceee690cfb 100644
--- a/test/lisp/progmodes/python-tests.el
+++ b/test/lisp/progmodes/python-tests.el
@@ -55,21 +55,27 @@ BODY is code to be executed within the temp buffer. Point
is
always located at the beginning of buffer. Native completion is
turned off. Shell buffer will be killed on exit."
(declare (indent 1) (debug t))
- `(with-temp-buffer
- (let ((python-indent-guess-indent-offset nil)
- (python-shell-completion-native-enable nil))
- (python-mode)
- (unwind-protect
- (progn
- (run-python nil t)
- (insert ,contents)
- (goto-char (point-min))
- (python-tests-shell-wait-for-prompt)
- ,@body)
- (when (python-shell-get-buffer)
- (python-shell-with-shell-buffer
- (let (kill-buffer-hook kill-buffer-query-functions)
- (kill-buffer))))))))
+ (let ((dir (make-symbol "dir")))
+ `(with-temp-buffer
+ (let ((python-indent-guess-indent-offset nil)
+ (python-shell-completion-native-enable nil))
+ (python-mode)
+ (unwind-protect
+ ;; Prevent test failures when Jedi is used as a completion
+ ;; backend, either directly or indirectly (e.g., via
+ ;; IPython). Jedi needs to store cache, but the
+ ;; "/nonexistent" HOME directory is not writable.
+ (ert-with-temp-directory ,dir
+ (with-environment-variables (("XDG_CACHE_HOME" ,dir))
+ (run-python nil t)
+ (insert ,contents)
+ (goto-char (point-min))
+ (python-tests-shell-wait-for-prompt)
+ ,@body))
+ (when (python-shell-get-buffer)
+ (python-shell-with-shell-buffer
+ (let (kill-buffer-hook kill-buffer-query-functions)
+ (kill-buffer)))))))))
(defmacro python-tests-with-temp-file (contents &rest body)
"Create a `python-mode' enabled file with CONTENTS.
@@ -4799,6 +4805,111 @@ def foo():
(end-of-line 0)
(should-not (nth 2 (python-shell-completion-at-point))))))
+(defun python-tests--completion-module ()
+ "Check if modules can be completed in Python shell."
+ (insert "import datet")
+ (completion-at-point)
+ (beginning-of-line)
+ (should (looking-at-p "import datetime"))
+ (kill-line)
+ (insert "from datet")
+ (completion-at-point)
+ (beginning-of-line)
+ (should (looking-at-p "from datetime"))
+ (end-of-line)
+ (insert " import timed")
+ (completion-at-point)
+ (beginning-of-line)
+ (should (looking-at-p "from datetime import timedelta"))
+ (kill-line))
+
+(defun python-tests--completion-parameters ()
+ "Check if parameters can be completed in Python shell."
+ (insert "import re")
+ (comint-send-input)
+ (python-tests-shell-wait-for-prompt)
+ (insert "re.split('b', 'abc', maxs")
+ (completion-at-point)
+ (should (string= "re.split('b', 'abc', maxsplit="
+ (buffer-substring (line-beginning-position) (point))))
+ (insert "0, ")
+ (should (python-shell-completion-at-point))
+ ;; Test if cache is used.
+ (cl-letf (((symbol-function 'python-shell-completion-get-completions)
+ 'ignore)
+ ((symbol-function 'python-shell-completion-native-get-completions)
+ 'ignore))
+ (insert "fla")
+ (completion-at-point)
+ (should (string= "re.split('b', 'abc', maxsplit=0, flags="
+ (buffer-substring (line-beginning-position) (point)))))
+ (beginning-of-line)
+ (kill-line))
+
+(defun python-tests--completion-extra-context ()
+ "Check if extra context is used for completion."
+ (insert "re.split('b', 'abc',")
+ (comint-send-input)
+ (python-tests-shell-wait-for-prompt)
+ (insert "maxs")
+ (completion-at-point)
+ (should (string= "maxsplit="
+ (buffer-substring (line-beginning-position) (point))))
+ (insert "0)")
+ (comint-send-input)
+ (python-tests-shell-wait-for-prompt)
+ (insert "from re import (")
+ (comint-send-input)
+ (python-tests-shell-wait-for-prompt)
+ (insert "IGN")
+ (completion-at-point)
+ (should (string= "IGNORECASE"
+ (buffer-substring (line-beginning-position) (point)))))
+
+(defun python-tests--pythonstartup-file ()
+ "Return Jedi readline setup file if PYTHONSTARTUP is not set."
+ (or (getenv "PYTHONSTARTUP")
+ (with-temp-buffer
+ (if (eql 0 (call-process python-tests-shell-interpreter
+ nil t nil "-m" "jedi" "repl"))
+ (string-trim (buffer-string))
+ ""))))
+
+(ert-deftest python-shell-completion-at-point-jedi-completer ()
+ "Check if Python shell completion works when Jedi completer is used."
+ (skip-unless (executable-find python-tests-shell-interpreter))
+ (with-environment-variables
+ (("PYTHONSTARTUP" (python-tests--pythonstartup-file)))
+ (python-tests-with-temp-buffer-with-shell
+ ""
+ (python-shell-with-shell-buffer
+ (python-shell-completion-native-turn-on)
+ (skip-unless (string= python-shell-readline-completer-delims ""))
+ (python-tests--completion-module)
+ (python-tests--completion-parameters)
+ (python-tests--completion-extra-context)))))
+
+(ert-deftest python-shell-completion-at-point-ipython ()
+ "Check if Python shell completion works for IPython."
+ (let ((python-shell-interpreter "ipython")
+ (python-shell-interpreter-args "-i --simple-prompt"))
+ (skip-unless
+ (and
+ (executable-find python-shell-interpreter)
+ (eql (call-process python-shell-interpreter nil nil nil "--version") 0)))
+ (with-environment-variables
+ (("PYTHONSTARTUP" (python-tests--pythonstartup-file)))
+ (python-tests-with-temp-buffer-with-shell
+ ""
+ (python-shell-with-shell-buffer
+ (python-shell-completion-native-turn-off)
+ (python-tests--completion-module)
+ (python-tests--completion-parameters)
+ (python-shell-completion-native-turn-on)
+ (skip-unless (string= python-shell-readline-completer-delims ""))
+ (python-tests--completion-module)
+ (python-tests--completion-parameters)
+ (python-tests--completion-extra-context))))))
;;; PDB Track integration
@@ -4945,11 +5056,6 @@ import abc
(ert-deftest python-ffap-module-path-1 ()
(skip-unless (executable-find python-tests-shell-interpreter))
- ;; Skip the test on macOS, since the standard Python installation uses
- ;; libedit rather than readline which confuses the running of an inferior
- ;; interpreter in this case (see bug#59477 and bug#25753).
- (skip-when (eq system-type 'darwin))
- (trace-function 'python-shell-output-filter)
(python-tests-with-temp-buffer-with-shell
"
import abc
diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el
index ba51f375cc6..e50738f1122 100644
--- a/test/lisp/thingatpt-tests.el
+++ b/test/lisp/thingatpt-tests.el
@@ -92,6 +92,8 @@
("1@example.com" 1 email "1@example.com")
;; email addresses user portion containing dots
("foo.bar@example.com" 1 email "foo.bar@example.com")
+ ("foo.bar@example.com" 5 email "foo.bar@example.com")
+ (" fo.ba@example.com" 6 email "fo.ba@example.com")
(".foobar@example.com" 1 email nil)
(".foobar@example.com" 2 email "foobar@example.com")
;; email addresses domain portion containing dots and dashes
@@ -180,6 +182,13 @@ position to retrieve THING.")
(should (thing-at-point-looking-at "2abcd"))
(should (equal (match-data) m2)))))
+(ert-deftest thing-at-point-looking-at-overlapping-matches ()
+ (with-temp-buffer
+ (insert "foo.bar.baz")
+ (goto-char (point-max))
+ (should (thing-at-point-looking-at "[a-z]+\\.[a-z]+"))
+ (should (string= "bar.baz" (match-string 0)))))
+
(ert-deftest test-symbol-thing-1 ()
(with-temp-buffer
(insert "foo bar zot")
diff --git a/test/src/comp-resources/comp-test-funcs.el
b/test/src/comp-resources/comp-test-funcs.el
index 4cee084e211..dc4abf50767 100644
--- a/test/src/comp-resources/comp-test-funcs.el
+++ b/test/src/comp-resources/comp-test-funcs.el
@@ -367,11 +367,11 @@
(while (consp insn)
(let ((newcar (car insn)))
(if (or (consp (car insn)) (comp-mvar-p (car insn)))
- (setf newcar (comp-copy-insn (car insn))))
+ (setf newcar (comp--copy-insn (car insn))))
(push newcar result))
(setf insn (cdr insn)))
(nconc (nreverse result)
- (if (comp-mvar-p insn) (comp-copy-insn insn) insn)))
+ (if (comp-mvar-p insn) (comp--copy-insn insn) insn)))
(if (comp-mvar-p insn)
(copy-comp-mvar insn)
insn)))
diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el
index 8bfe939fb23..67d632823b2 100644
--- a/test/src/comp-tests.el
+++ b/test/src/comp-tests.el
@@ -904,16 +904,23 @@ Return a list of results."
(should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f)))
(should (= (comp-tests-fw-prop-1-f) 6))))
+(defun comp-tests--type-lists-equal (l1 l2)
+ (and (= (length l1) (length l2))
+ (cl-every #'comp-tests--types-equal l1 l2)))
+
(defun comp-tests--types-equal (t1 t2)
- "Whether the types T1 and T2 are equal."
- (or (equal t1 t2) ; optimization for the common case
- (and (consp t1) (consp t2)
- (eq (car t1) (car t2))
- (if (memq (car t1) '(and or member))
- (null (cl-set-exclusive-or (cdr t1) (cdr t2)
- :test #'comp-tests--types-equal))
- (and (= (length t1) (length t2))
- (cl-every #'comp-tests--types-equal (cdr t1) (cdr t2)))))))
+ "Whether the types T1 and T2 are equal."
+ (or (equal t1 t2) ; for atoms, and optimization for the common case
+ (and (consp t1) (consp t2)
+ (eq (car t1) (car t2))
+ (cond ((memq (car t1) '(and or member))
+ ;; Order or duplicates don't matter.
+ (null (cl-set-exclusive-or (cdr t1) (cdr t2)
+ :test #'comp-tests--types-equal)))
+ ((eq (car t1) 'function)
+ (and (comp-tests--type-lists-equal (nth 1 t1) (nth 1 t2))
+ (comp-tests--types-equal (nth 2 t1) (nth 2 t2))))
+ (t (comp-tests--type-lists-equal (cdr t1) (cdr t2)))))))
(defun comp-tests-check-ret-type-spec (func-form ret-type)
(let ((lexical-binding t)
diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el
index e1c90feb09a..187dc2f34d5 100644
--- a/test/src/eval-tests.el
+++ b/test/src/eval-tests.el
@@ -282,26 +282,39 @@ expressions works for identifiers starting with period."
(should-error (defvaralias 'eval-tests--my-c 'eval-tests--my-d)
:type 'cyclic-variable-indirection))
-(defvar eval-tests/global-var 'value)
-(defvar-local eval-tests/buffer-local-var 'value)
+(defvar eval-tests/global-var 'global-value)
+(defvar-local eval-tests/buffer-local-var 'default-value)
(ert-deftest eval-tests/default-value ()
;; `let' overrides the default value for global variables.
(should (default-boundp 'eval-tests/global-var))
- (should (eq 'value (default-value 'eval-tests/global-var)))
- (should (eq 'value eval-tests/global-var))
- (let ((eval-tests/global-var 'bar))
- (should (eq 'bar (default-value 'eval-tests/global-var)))
- (should (eq 'bar eval-tests/global-var)))
+ (should (eq 'global-value (default-value 'eval-tests/global-var)))
+ (should (eq 'global-value eval-tests/global-var))
+ (let ((eval-tests/global-var 'let-value))
+ (should (eq 'let-value (default-value 'eval-tests/global-var)))
+ (should (eq 'let-value eval-tests/global-var)))
;; `let' overrides the default value everywhere, but leaves
;; buffer-local values unchanged in current buffer and in the
;; buffers where there is no explicitly set buffer-local value.
(should (default-boundp 'eval-tests/buffer-local-var))
- (should (eq 'value (default-value 'eval-tests/buffer-local-var)))
- (should (eq 'value eval-tests/buffer-local-var))
+ (should (eq 'default-value (default-value 'eval-tests/buffer-local-var)))
+ (should (eq 'default-value eval-tests/buffer-local-var))
(with-temp-buffer
- (let ((eval-tests/buffer-local-var 'bar))
- (should (eq 'bar (default-value 'eval-tests/buffer-local-var)))
- (should (eq 'bar eval-tests/buffer-local-var)))))
+ (let ((eval-tests/buffer-local-var 'let-value))
+ (should (eq 'let-value (default-value 'eval-tests/buffer-local-var)))
+ (should (eq 'let-value eval-tests/buffer-local-var))))
+ ;; When current buffer has explicit buffer-local binding, `let' does
+ ;; not alter the default binding.
+ (with-temp-buffer
+ (setq-local eval-tests/buffer-local-var 'local-value)
+ (let ((eval-tests/buffer-local-var 'let-value))
+ ;; Let in a buffer with local binding does not change the
+ ;; default value for variable.
+ (should (eq 'default-value (default-value 'eval-tests/buffer-local-var)))
+ (should (eq 'let-value eval-tests/buffer-local-var))
+ (with-temp-buffer
+ ;; We are in a new buffer - `eval-tests/buffer-local-var' has its
global default value.
+ (should (eq 'default-value (default-value
'eval-tests/buffer-local-var)))
+ (should (eq 'default-value eval-tests/buffer-local-var))))))
(ert-deftest eval-tests--handler-bind ()
;; A `handler-bind' has no effect if no error is signaled.
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index 3893b8b0320..7437c07f156 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -1097,6 +1097,16 @@
(should (= (sxhash-equal (record 'a (make-string 10 ?a)))
(sxhash-equal (record 'a (make-string 10 ?a))))))
+(ert-deftest fns--define-hash-table-test ()
+ ;; Check that we can have two differently-named tests using the
+ ;; same functions (bug#68668).
+ (define-hash-table-test 'fns-tests--1 'my-cmp 'my-hash)
+ (define-hash-table-test 'fns-tests--2 'my-cmp 'my-hash)
+ (let ((h1 (make-hash-table :test 'fns-tests--1))
+ (h2 (make-hash-table :test 'fns-tests--2)))
+ (should (eq (hash-table-test h1) 'fns-tests--1))
+ (should (eq (hash-table-test h2) 'fns-tests--2))))
+
(ert-deftest test-secure-hash ()
(should (equal (secure-hash 'md5 "foobar")
"3858f62230ac3c915f300c664312c63f"))
diff --git a/test/src/minibuf-tests.el b/test/src/minibuf-tests.el
index 14d160df25c..99d522d1856 100644
--- a/test/src/minibuf-tests.el
+++ b/test/src/minibuf-tests.el
@@ -34,7 +34,7 @@
(let ((num 0))
(mapcar (lambda (str) (cons str (cl-incf num))) list)))
(defun minibuf-tests--strings-to-obarray (list)
- (let ((ob (make-vector 7 0)))
+ (let ((ob (obarray-make 7)))
(mapc (lambda (str) (intern str ob)) list)
ob))
(defun minibuf-tests--strings-to-string-hashtable (list)
@@ -61,6 +61,9 @@
;;; Testing functions that are agnostic to type of COLLECTION.
+(defun minibuf-tests--set-equal (a b)
+ (null (cl-set-exclusive-or a b :test #'equal)))
+
(defun minibuf-tests--try-completion (xform-collection)
(let* ((abcdef (funcall xform-collection '("abc" "def")))
(+abba (funcall xform-collection '("abc" "abba" "def"))))
@@ -101,7 +104,8 @@
(let* ((abcdef (funcall xform-collection '("abc" "def")))
(+abba (funcall xform-collection '("abc" "abba" "def"))))
(should (equal (all-completions "a" abcdef) '("abc")))
- (should (equal (all-completions "a" +abba) '("abc" "abba")))
+ (should (minibuf-tests--set-equal (all-completions "a" +abba)
+ '("abc" "abba")))
(should (equal (all-completions "abc" +abba) '("abc")))
(should (equal (all-completions "abcd" +abba) nil))))
@@ -111,7 +115,8 @@
(+abba (funcall xform-collection '("abc" "abba" "def")))
(+abba-member (funcall collection-member +abba)))
(should (equal (all-completions "a" abcdef abcdef-member) '("abc")))
- (should (equal (all-completions "a" +abba +abba-member) '("abc" "abba")))
+ (should (minibuf-tests--set-equal (all-completions "a" +abba +abba-member)
+ '("abc" "abba")))
(should (equal (all-completions "abc" +abba +abba-member) '("abc")))
(should (equal (all-completions "abcd" +abba +abba-member) nil))
(should-not (all-completions "a" abcdef #'ignore))
@@ -124,7 +129,8 @@
(+abba (funcall xform-collection '("abc" "abba" "def"))))
(let ((completion-regexp-list '(".")))
(should (equal (all-completions "a" abcdef) '("abc")))
- (should (equal (all-completions "a" +abba) '("abc" "abba")))
+ (should (minibuf-tests--set-equal (all-completions "a" +abba)
+ '("abc" "abba")))
(should (equal (all-completions "abc" +abba) '("abc")))
(should (equal (all-completions "abcd" +abba) nil)))
(let ((completion-regexp-list '("X")))
diff --git a/test/src/treesit-tests.el b/test/src/treesit-tests.el
index a89bf1298c0..bdc9630c783 100644
--- a/test/src/treesit-tests.el
+++ b/test/src/treesit-tests.el
@@ -254,7 +254,7 @@
(should (eq nil (treesit-node-text
(treesit-search-subtree
subarray "\\["))))
- ;; If ALL=nil, searching for number should still find the
+ ;; If ALL=t, searching for number should still find the
;; numbers.
(should (equal "1" (treesit-node-text
(treesit-search-subtree